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 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 to 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