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/Server.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 src/Propellor/Server.hs (limited to 'src/Propellor/Server.hs') 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.3-2-g0d8e From f0675727c2833a8ebe8b954384ca484559b3b378 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 01:02:54 -0400 Subject: propellor spin --- src/Propellor/Server.hs | 1 - 1 file changed, 1 deletion(-) (limited to 'src/Propellor/Server.hs') diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 1b31234b..182cc2b5 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -10,7 +10,6 @@ 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 -- cgit v1.3-2-g0d8e From d130e7e628568be9593474fbe5601239c6ce8a2e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 21:48:48 -0400 Subject: propellor spin --- src/Propellor/Git.hs | 3 ++- src/Propellor/Message.hs | 11 +++++++---- src/Propellor/Server.hs | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) (limited to 'src/Propellor/Server.hs') diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs index 88d5c3ab..73de1def 100644 --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -69,7 +69,8 @@ fetchOrigin = do branchref <- getCurrentBranch let originbranch = "origin" branchref - void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"] + void $ actionMessage "Pull from central git repository" $ + boolSystem "git" [Param "fetch"] oldsha <- getCurrentGitSha1 branchref diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index a5d4d2ca..244913ea 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -15,16 +15,19 @@ import Control.Applicative import Propellor.Types import Utility.Monad import Utility.Env +import Utility.FileSystemEncoding data MessageHandle = ConsoleMessageHandle | TextMessageHandle mkMessageHandle :: IO MessageHandle -mkMessageHandle = ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) - ( return ConsoleMessageHandle - , return TextMessageHandle - ) +mkMessageHandle = do + fileEncoding stdout + ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) + ( return ConsoleMessageHandle + , return TextMessageHandle + ) forceConsole :: IO () forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True diff --git a/src/Propellor/Server.hs b/src/Propellor/Server.hs index 182cc2b5..513a81f4 100644 --- a/src/Propellor/Server.hs +++ b/src/Propellor/Server.hs @@ -20,7 +20,7 @@ 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 +-- connection, talking to the user's local propellor instance which is -- running the updateServer update :: IO () update = do -- cgit v1.3-2-g0d8e