{-# Language ScopedTypeVariables #-}

module Propellor.Spin (
	commitSpin,
	spin,
	spin',
	update,
	gitPushHelper,
	mergeSpin,
) where

import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
import System.Posix.Directory
import Control.Concurrent.Async
import qualified Data.ByteString as B
import qualified Data.Set as S
import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)

import Propellor.Base
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Git.Config
import Propellor.Ssh
import Propellor.Gpg
import Propellor.Bootstrap
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Property.Localdir (OriginUrl(..))
import qualified Propellor.Shim as Shim
import Utility.SafeCommand
import Utility.Process.NonConcurrent

commitSpin :: IO ()
commitSpin :: IO ()
commitSpin = do
	-- safety check #1: check we're on the configured spin branch
	Maybe String
spinBranch <- String -> IO (Maybe String)
getGitConfigValue String
"propellor.spin-branch"
	case Maybe String
spinBranch of
		Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- just a noop
		Just String
b -> do
			String
currentBranch <- IO String
getCurrentBranch
			Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
currentBranch) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
				String -> IO ()
forall a. HasCallStack => String -> a
error (String
"spin aborted: check out "
					String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" branch first")

	-- safety check #2: check we can commit with a dirty tree
	Bool
noDirtySpin <- String -> IO Bool
getGitConfigBool String
"propellor.forbid-dirty-spin"
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noDirtySpin (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		String
status <- (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
			(String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"git" [String
"status", String
"--porcelain"]
		Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
status) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
			String -> IO ()
forall a. HasCallStack => String -> a
error String
"spin aborted: commit changes first"

	IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Git commit" (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
		Maybe String -> [CommandParam] -> IO Bool
gitCommit (String -> Maybe String
forall a. a -> Maybe a
Just String
spinCommitMessage)
			[String -> CommandParam
Param String
"--allow-empty", String -> CommandParam
Param String
"-a"]
	-- Push to central origin repo first, if possible.
	-- The remote propellor will pull from there, which avoids
	-- us needing to send stuff directly to the remote host.
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasOrigin (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Push to central git repository" (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
			String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"git" [String -> CommandParam
Param String
"push"]

spin :: Maybe HostName -> HostName -> Host -> IO ()
spin :: Maybe String -> String -> Host -> IO ()
spin = Maybe PrivMap -> Maybe String -> String -> Host -> IO ()
spin' Maybe PrivMap
forall a. Maybe a
Nothing

spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO ()
spin' :: Maybe PrivMap -> Maybe String -> String -> Host -> IO ()
spin' Maybe PrivMap
mprivdata Maybe String
relay String
target Host
hst = do
	[String]
cacheparams <- if Bool
viarelay
		then [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-A"]
		else [CommandParam] -> [String]
toCommand ([CommandParam] -> [String]) -> IO [CommandParam] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [CommandParam]
sshCachingParams String
hn
	Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
viarelay (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [CommandParam] -> IO Bool
boolSystem String
"ssh-add" []

	String
sshtarget <- (String
"root@" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe String
relay of
		Just String
r -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
r
		Maybe String
Nothing -> String -> Host -> IO String
getSshTarget String
target Host
hst

	-- Install, or update the remote propellor.
	String
-> Maybe String
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer String
target Maybe String
relay Host
hst
		(String -> [String] -> CreateProcess
proc String
"ssh" ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [String]
cacheparams [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
sshtarget, String -> String
shellWrap String
probecmd])
		(String -> [String] -> CreateProcess
proc String
"ssh" ([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [String]
cacheparams [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
sshtarget, String -> String
shellWrap String
updatecmd])
		(PrivMap -> IO ()) -> IO PrivMap -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO PrivMap
getprivdata

	-- And now we can run it.
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"ssh" ((String -> CommandParam) -> [String] -> [CommandParam]
forall a b. (a -> b) -> [a] -> [b]
map String -> CommandParam
Param ([String] -> [CommandParam]) -> [String] -> [CommandParam]
forall a b. (a -> b) -> a -> b
$ [String]
cacheparams [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-t", String
sshtarget, String -> String
shellWrap String
runcmd])) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. String -> a
giveup String
"remote propellor failed"
  where
	hn :: String
hn = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
target Maybe String
relay
	sys :: Maybe System
sys = case Info -> InfoVal System
forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
hst) of
		InfoVal System
o -> System -> Maybe System
forall a. a -> Maybe a
Just System
o
		InfoVal System
NoInfoVal -> Maybe System
forall a. Maybe a
Nothing
	bootstrapper :: Bootstrapper
bootstrapper = case Info -> InfoVal Bootstrapper
forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
hst) of
		InfoVal Bootstrapper
NoInfoVal -> Bootstrapper
defaultBootstrapper
		InfoVal Bootstrapper
bs -> Bootstrapper
bs

	relaying :: Bool
relaying = Maybe String
relay Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
target
	viarelay :: Bool
viarelay = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
relay Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
relaying

	probecmd :: String
probecmd = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ; "
		[ String
"if [ ! -d " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/.git ]"
		, String
"then (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
			[ Maybe System -> String
installGitCommand Maybe System
sys
			, String
"echo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
toMarked String
statusMarker (Stage -> String
forall a. Show a => a -> String
show Stage
NeedGitClone)
			] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") || echo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
toMarked String
statusMarker (Stage -> String
forall a. Show a => a -> String
show Stage
NeedPrecompiled)
		, String
"else " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
updatecmd
		, String
"fi"
		]

	updatecmd :: String
updatecmd = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
		[ String
"cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localdir
		, Bootstrapper -> Maybe System -> String
bootstrapPropellorCommand Bootstrapper
bootstrapper Maybe System
sys
		, if Bool
viarelay
			then String
"./propellor --continue " String -> String -> String
forall a. [a] -> [a] -> [a]
++
				String -> String
shellEscape (CmdLine -> String
forall a. Show a => a -> String
show (String -> CmdLine
Relay String
target))
			-- Still using --boot for back-compat...
			else String
"./propellor --boot " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target
		]

	runcmd :: String
runcmd = String
"cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" && ./propellor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd
	cmd :: String
cmd = String
"--serialized " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape (CmdLine -> String
forall a. Show a => a -> String
show CmdLine
cmdline)
	cmdline :: CmdLine
cmdline
		| Bool
viarelay = [String] -> Maybe String -> CmdLine
Spin [String
target] (String -> Maybe String
forall a. a -> Maybe a
Just String
target)
		| Bool
otherwise = String -> CmdLine
SimpleRun String
target

	getprivdata :: IO PrivMap
getprivdata = case Maybe PrivMap
mprivdata of
		Maybe PrivMap
Nothing
			| Bool
relaying -> do
				let f :: String
f = String -> String
privDataRelay String
hn
				PrivMap
d <- String -> IO PrivMap
readPrivDataFile String
f
				String -> IO ()
nukeFile String
f
				PrivMap -> IO PrivMap
forall (m :: * -> *) a. Monad m => a -> m a
return PrivMap
d
			| Bool
otherwise ->
				Host -> PrivMap -> PrivMap
filterPrivData Host
hst (PrivMap -> PrivMap) -> IO PrivMap -> IO PrivMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO PrivMap
decryptPrivData
		Just PrivMap
pd -> PrivMap -> IO PrivMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrivMap
pd

-- Check if the Host contains an IP address that matches one of the IPs
-- in the DNS for the HostName. If so, the HostName is used as-is,
-- but if the DNS is out of sync with the Host config, or doesn't have
-- the host in it at all, use one of the Host's IPs instead.
getSshTarget :: HostName -> Host -> IO String
getSshTarget :: String -> Host -> IO String
getSshTarget String
target Host
hst
	| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
configips = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
target
	| Bool
otherwise = Either IOException [AddrInfo] -> IO String
forall a. Show a => Either a [AddrInfo] -> IO String
go (Either IOException [AddrInfo] -> IO String)
-> IO (Either IOException [AddrInfo]) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [AddrInfo] -> IO (Either IOException [AddrInfo])
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (String -> IO [AddrInfo]
dnslookup String
target)
  where
	go :: Either a [AddrInfo] -> IO String
go (Left a
e) = String -> IO String
useip (a -> String
forall a. Show a => a -> String
show a
e)
	go (Right [AddrInfo]
addrinfos) = do
		[SockAddr]
configaddrinfos <- [Maybe SockAddr] -> [SockAddr]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SockAddr] -> [SockAddr])
-> IO [Maybe SockAddr] -> IO [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe SockAddr)) -> [String] -> IO [Maybe SockAddr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe SockAddr)
iptoaddr [String]
configips
		if (SockAddr -> Bool) -> [SockAddr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SockAddr -> [SockAddr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SockAddr]
configaddrinfos) ((AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress [AddrInfo]
addrinfos)
			then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
target
			else String -> IO String
useip (String
"DNS lookup did not return any of the expected addresses " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
configips)

	dnslookup :: String -> IO [AddrInfo]
dnslookup String
h = Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_CANONNAME] }) (String -> Maybe String
forall a. a -> Maybe a
Just String
h) Maybe String
forall a. Maybe a
Nothing

	-- Convert a string containing an IP address into a SockAddr.
	iptoaddr :: String -> IO (Maybe SockAddr)
	iptoaddr :: String -> IO (Maybe SockAddr)
iptoaddr String
ip = Maybe SockAddr -> IO (Maybe SockAddr) -> IO (Maybe SockAddr)
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO Maybe SockAddr
forall a. Maybe a
Nothing (IO (Maybe SockAddr) -> IO (Maybe SockAddr))
-> IO (Maybe SockAddr) -> IO (Maybe SockAddr)
forall a b. (a -> b) -> a -> b
$ [SockAddr] -> Maybe SockAddr
forall a. [a] -> Maybe a
headMaybe ([SockAddr] -> Maybe SockAddr)
-> ([AddrInfo] -> [SockAddr]) -> [AddrInfo] -> Maybe SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress
		([AddrInfo] -> Maybe SockAddr)
-> IO [AddrInfo] -> IO (Maybe SockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just (AddrInfo -> Maybe AddrInfo) -> AddrInfo -> Maybe AddrInfo
forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICHOST] })  (String -> Maybe String
forall a. a -> Maybe a
Just String
ip) Maybe String
forall a. Maybe a
Nothing

	useip :: String -> IO String
useip String
why = case [String] -> Maybe String
forall a. [a] -> Maybe a
headMaybe [String]
configips of
		Maybe String
Nothing -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
target
		Just String
ip -> do
			-- If we're being asked to run on the local host,
			-- ignore DNS.
			String
s <- (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"hostname" [String
"-f"]
			if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
target
				then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
target
				else do
					String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"DNS seems out of date for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
target String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
why String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"); using IP address from configuration instead."
					String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ip

	configips :: [String]
configips = (IPAddr -> String) -> [IPAddr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IPAddr -> String
forall t. ConfigurableValue t => t -> String
val ([IPAddr] -> [String]) -> [IPAddr] -> [String]
forall a b. (a -> b) -> a -> b
$ (Record -> Maybe IPAddr) -> [Record] -> [IPAddr]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Record -> Maybe IPAddr
getIPAddr ([Record] -> [IPAddr]) -> [Record] -> [IPAddr]
forall a b. (a -> b) -> a -> b
$
		Set Record -> [Record]
forall a. Set a -> [a]
S.toList (Set Record -> [Record]) -> Set Record -> [Record]
forall a b. (a -> b) -> a -> b
$ Info -> Set Record
getDnsInfo (Info -> Set Record) -> Info -> Set Record
forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
hst

-- 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 :: Maybe HostName -> IO ()
update :: Maybe String -> IO ()
update Maybe String
forhost = do
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasGitRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		Stage -> String -> (String -> IO ()) -> IO ()
req Stage
NeedRepoUrl String
repoUrlMarker String -> IO ()
setRepoUrl

	IO ()
makePrivDataDir
	Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
privfile)
	Stage -> String -> (String -> IO ()) -> IO ()
req Stage
NeedPrivData String
privDataMarker ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> String -> IO ()
writeFileProtected String
privfile

	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasGitRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		IO ()
gitPullFromUpdateServer
  where
	-- When --spin --relay is run, get a privdata file
	-- to be relayed to the target host.
	privfile :: String
privfile = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
privDataLocal String -> String
privDataRelay Maybe String
forhost

updateServer
	:: HostName
	-> Maybe HostName
	-> Host
	-> CreateProcess
	-> CreateProcess
	-> PrivMap
	-> IO ()
updateServer :: String
-> Maybe String
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer String
target Maybe String
relay Host
hst CreateProcess
connect CreateProcess
haveprecompiled PrivMap
privdata = do
	(Just Handle
toh, Just Handle
fromh, Maybe Handle
_, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcessNonConcurrent (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
connect
		{ std_in :: StdStream
std_in = StdStream
CreatePipe
		, std_out :: StdStream
std_out = StdStream
CreatePipe
		}
	(Handle, Handle) -> IO ()
go (Handle
toh, Handle
fromh)
	CreateProcess -> ExitCode -> IO ()
forceSuccessProcess' CreateProcess
connect (ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> IO ExitCode
waitForProcessNonConcurrent ProcessHandle
pid
  where
	hn :: String
hn = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
target Maybe String
relay

	go :: (Handle, Handle) -> IO ()
go (Handle
toh, Handle
fromh) = do
		let loop :: IO ()
loop = (Handle, Handle) -> IO ()
go (Handle
toh, Handle
fromh)
		let restart :: IO ()
restart = String
-> Maybe String
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer String
hn Maybe String
relay Host
hst CreateProcess
connect CreateProcess
haveprecompiled PrivMap
privdata
		let done :: IO ()
done = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Maybe Stage
v <- Maybe Stage
-> (String -> Maybe Stage) -> Maybe String -> Maybe Stage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Stage
forall a. Maybe a
Nothing String -> Maybe Stage
forall a. Read a => String -> Maybe a
readish (Maybe String -> Maybe Stage)
-> IO (Maybe String) -> IO (Maybe Stage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> String -> IO (Maybe String)
getMarked Handle
fromh String
statusMarker
		case Maybe Stage
v of
			(Just Stage
NeedRepoUrl) -> do
				Host -> Handle -> IO ()
sendRepoUrl Host
hst Handle
toh
				IO ()
loop
			(Just Stage
NeedPrivData) -> do
				String -> Handle -> PrivMap -> IO ()
sendPrivData String
hn Handle
toh PrivMap
privdata
				IO ()
loop
			(Just Stage
NeedGitClone) -> do
				Handle -> IO ()
hClose Handle
toh
				Handle -> IO ()
hClose Handle
fromh
				String -> IO ()
sendGitClone String
hn
				IO ()
restart
			(Just Stage
NeedPrecompiled) -> do
				Handle -> IO ()
hClose Handle
toh
				Handle -> IO ()
hClose Handle
fromh
				String -> IO ()
sendPrecompiled String
hn
				String
-> Maybe String
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer String
hn Maybe String
relay Host
hst CreateProcess
haveprecompiled (String -> CreateProcess
forall a. HasCallStack => String -> a
error String
"loop") PrivMap
privdata
			(Just Stage
NeedGitPush) -> do
				String -> Handle -> Handle -> IO ()
sendGitUpdate String
hn Handle
fromh Handle
toh
				Handle -> IO ()
hClose Handle
fromh
				Handle -> IO ()
hClose Handle
toh
				IO ()
done
			Maybe Stage
Nothing -> IO ()
done

sendRepoUrl :: Host -> Handle -> IO ()
sendRepoUrl :: Host -> Handle -> IO ()
sendRepoUrl Host
hst Handle
toh = Handle -> String -> String -> IO ()
sendMarked Handle
toh String
repoUrlMarker (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
geturl
  where
	geturl :: IO String
geturl = case InfoVal OriginUrl -> Maybe OriginUrl
forall v. InfoVal v -> Maybe v
fromInfoVal (Info -> InfoVal OriginUrl
forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
hst)) of
		Maybe OriginUrl
Nothing -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String)
getRepoUrl
		Just (OriginUrl String
u) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
u

sendPrivData :: HostName -> Handle -> PrivMap -> IO ()
sendPrivData :: String -> Handle -> PrivMap -> IO ()
sendPrivData String
hn Handle
toh PrivMap
privdata = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
msg (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
	Handle -> String -> String -> IO ()
sendMarked Handle
toh String
privDataMarker String
d
	Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
	msg :: String
msg = String
"Sending privdata (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes) to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hn
	d :: String
d = PrivMap -> String
forall a. Show a => a -> String
show PrivMap
privdata

sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate :: String -> Handle -> Handle -> IO ()
sendGitUpdate String
hn Handle
fromh Handle
toh =
	IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage (String
"Sending git update to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hn) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
		Handle -> String -> String -> IO ()
sendMarked Handle
toh String
gitPushMarker String
""
		(Maybe Handle
Nothing, Maybe Handle
Nothing, Maybe Handle
Nothing, ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
p
		ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
(==) ExitCode
ExitSuccess (ExitCode -> Bool) -> IO ExitCode -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h
  where
	p :: CreateProcess
p = (String -> [String] -> CreateProcess
proc String
"git" [String
"upload-pack", String
"."])
		{ std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
fromh
		, std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
toh
		}

-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone :: String -> IO ()
sendGitClone String
hn = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage (String
"Clone git repository to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hn) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
	String
branch <- IO String
getCurrentBranch
	[CommandParam]
cacheparams <- String -> IO [CommandParam]
sshCachingParams String
hn
	String -> (String -> Handle -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withTmpFile String
"propellor.git" ((String -> Handle -> IO Bool) -> IO Bool)
-> (String -> Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
tmp Handle
_ -> (IO Bool -> IO Bool) -> [IO Bool] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM IO Bool -> IO Bool
forall a. a -> a
id
		[ String -> [CommandParam] -> IO Bool
boolSystem String
"git" [String -> CommandParam
Param String
"bundle", String -> CommandParam
Param String
"create", String -> CommandParam
File String
tmp, String -> CommandParam
Param String
"HEAD"]
		, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"scp" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
File String
tmp, String -> CommandParam
Param (String
"root@"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hnString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
remotebundle)]
		, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"ssh" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
Param (String
"root@"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hn), String -> CommandParam
Param (String -> CommandParam) -> String -> CommandParam
forall a b. (a -> b) -> a -> b
$ String -> String
unpackcmd String
branch]
		]
  where
	remotebundle :: String
remotebundle = String
"/usr/local/propellor.git"
	unpackcmd :: String -> String
unpackcmd String
branch = String -> String
shellWrap (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
		[ String
"git clone " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remotebundle String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localdir
		, String
"cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localdir
		, String
"git checkout -b " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
branch
		, String
"git remote rm origin"
		, String
"rm -f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remotebundle
		]

-- Send a tarball containing the precompiled propellor, and libraries.
-- This should be reasonably portable, as long as the remote host has the
-- same architecture as the build host.
sendPrecompiled :: HostName -> IO ()
sendPrecompiled :: String -> IO ()
sendPrecompiled String
hn = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO Bool -> IO Bool
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Uploading locally compiled propellor as a last resort" (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
	IO String -> (String -> IO ()) -> (String -> IO Bool) -> IO Bool
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO String
getWorkingDirectory String -> IO ()
changeWorkingDirectory ((String -> IO Bool) -> IO Bool) -> (String -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
_ ->
		String -> (String -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> (String -> m a) -> m a
withTmpDir String
"propellor" String -> IO Bool
go
  where
	go :: String -> IO Bool
go String
tmpdir = do
		[CommandParam]
cacheparams <- String -> IO [CommandParam]
sshCachingParams String
hn
		let shimdir :: String
shimdir = String -> String
takeFileName String
localdir
		Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
tmpdir String -> String -> String
</> String
shimdir)
		String -> IO ()
changeWorkingDirectory (String
tmpdir String -> String -> String
</> String
shimdir)
		String
me <- String -> IO String
readSymbolicLink String
"/proc/self/exe"
		Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
"bin"
		IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystem String
"cp" [String -> CommandParam
File String
me, String -> CommandParam
File String
"bin/propellor"]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
			String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"failed copying in propellor"
		let bin :: String
bin = String
"bin/propellor"
		let binpath :: Maybe String
binpath = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
localdir String -> String -> String
</> String
bin
		IO String -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String -> IO String
Shim.setup String
bin Maybe String
binpath String
"."
		String -> IO ()
changeWorkingDirectory String
tmpdir
		String -> (String -> Handle -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withTmpFile String
"propellor.tar." ((String -> Handle -> IO Bool) -> IO Bool)
-> (String -> Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
tarball Handle
_ -> (IO Bool -> IO Bool) -> [IO Bool] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM IO Bool -> IO Bool
forall a. a -> a
id
			[ String -> [CommandParam] -> IO Bool
boolSystem String
"strip" [String -> CommandParam
File String
me]
			, String -> [CommandParam] -> IO Bool
boolSystem String
"tar" [String -> CommandParam
Param String
"czf", String -> CommandParam
File String
tarball, String -> CommandParam
File String
shimdir]
			, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"scp" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
File String
tarball, String -> CommandParam
Param (String
"root@"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hnString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
remotetarball)]
			, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"ssh" ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams [CommandParam] -> [CommandParam] -> [CommandParam]
forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
Param (String
"root@"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hn), String -> CommandParam
Param String
unpackcmd]
			]

	remotetarball :: String
remotetarball = String
"/usr/local/propellor.tar"

	unpackcmd :: String
unpackcmd = String -> String
shellWrap (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
		[ String
"cd " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeDirectory String
remotetarball
		, String
"tar xzf " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remotetarball
		, String
"rm -f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
remotetarball
		]

mergeSpin :: IO ()
mergeSpin :: IO ()
mergeSpin = do
	String
branch <- IO String
getCurrentBranch
	String
branchref <- IO String
getCurrentBranchRef
	String
old_head <- String -> IO String
getCurrentGitSha1 String
branch
	String
old_commit <- IO String
findLastNonSpinCommit
	String -> [CommandParam] -> IO ()
rungit String
"reset" [String -> CommandParam
Param String
old_commit]
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Maybe String -> [CommandParam] -> IO Bool
gitCommit Maybe String
forall a. Maybe a
Nothing [String -> CommandParam
Param String
"-a", String -> CommandParam
Param String
"--allow-empty"]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. HasCallStack => String -> a
error String
"git commit failed"
	String -> [CommandParam] -> IO ()
rungit String
"merge" ([CommandParam] -> IO ()) -> IO [CommandParam] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [CommandParam] -> IO [CommandParam]
gpgSignParams [String -> CommandParam
Param String
"-s", String -> CommandParam
Param String
"ours", String -> CommandParam
Param String
old_head, String -> CommandParam
Param String
"--no-edit"]
	String
current_commit <- String -> IO String
getCurrentGitSha1 String
branch
	String -> [CommandParam] -> IO ()
rungit String
"update-ref" [String -> CommandParam
Param String
branchref, String -> CommandParam
Param String
current_commit]
	String -> [CommandParam] -> IO ()
rungit String
"checkout" [String -> CommandParam
Param String
branch]
  where
	rungit :: String -> [CommandParam] -> IO ()
rungit String
cmd [CommandParam]
ps = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystem String
"git" (String -> CommandParam
Param String
cmdCommandParam -> [CommandParam] -> [CommandParam]
forall a. a -> [a] -> [a]
:[CommandParam]
ps)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall a. HasCallStack => String -> a
error (String
"git " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed")

findLastNonSpinCommit :: IO String
findLastNonSpinCommit :: IO String
findLastNonSpinCommit = do
	[(String, String)]
commits <- (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		(String -> [(String, String)])
-> IO String -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"git" [String
"log", String
"--oneline", String
"--no-abbrev-commit"]
	case ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(String
_, String
msg) -> String
msg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
spinCommitMessage) [(String, String)]
commits of
		((String
sha, String
_):[(String, String)]
_) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
sha
		[(String, String)]
_ -> String -> IO String
forall a. HasCallStack => String -> a
error (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Did not find any previous commit that was not a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
spinCommitMessage

spinCommitMessage :: String
spinCommitMessage :: String
spinCommitMessage = String
"propellor spin"

-- Stdin and stdout are connected to the updateServer over ssh.
-- Request that it run git upload-pack, and connect that up to a git fetch
-- to receive the data.
gitPullFromUpdateServer :: IO ()
gitPullFromUpdateServer :: IO ()
gitPullFromUpdateServer = Stage -> String -> (String -> IO ()) -> IO ()
req Stage
NeedGitPush String
gitPushMarker ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
_ -> do
	-- IO involving stdin can cause data to be buffered in the Handle
	-- (even when it's set NoBuffering), but we need to pass a FD to 
	-- git fetch containing all of stdin after the gitPushMarker,
	-- including any that has been buffered.
	--
	-- To do so, create a pipe, and forward stdin, including any
	-- buffered part, through it.
	(Fd
pread, Fd
pwrite) <- IO (Fd, Fd)
System.Posix.IO.createPipe
	-- Note that there is a race between the createPipe and setting
	-- CloseOnExec. Another processess forked here would inherit
	-- pwrite and perhaps keep it open. However, propellor is not
	-- running concurrent threads at this point, so this is ok.
	Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
pwrite FdOption
CloseOnExec Bool
True
	Handle
hwrite <- Fd -> IO Handle
fdToHandle Fd
pwrite
	Async ()
forwarder <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Handle
stdin Handle -> Handle -> IO ()
*>* Handle
hwrite
	let hin :: Fd
hin = Fd
pread
	Fd
hout <- Fd -> IO Fd
dup Fd
stdOutput
	Handle -> IO ()
hClose Handle
stdout
	-- Not using git pull because git 2.5.0 badly
	-- broke its option parser.
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"git" (Fd -> Fd -> [CommandParam]
forall a a. (Show a, Show a) => a -> a -> [CommandParam]
fetchparams Fd
hin Fd
hout)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"git fetch from client failed"
	Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
forwarder
	IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"git" [String -> CommandParam
Param String
"merge", String -> CommandParam
Param String
"FETCH_HEAD"]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
		String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"git merge from client failed"
  where
	fetchparams :: a -> a -> [CommandParam]
fetchparams a
hin a
hout =
		[ String -> CommandParam
Param String
"fetch"
		, String -> CommandParam
Param String
"--progress"
		, String -> CommandParam
Param String
"--upload-pack"
		, String -> CommandParam
Param (String -> CommandParam) -> String -> CommandParam
forall a b. (a -> b) -> a -> b
$ String
"./propellor --gitpush " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hin String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
hout
		, String -> CommandParam
Param String
"."
		]

-- 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 :: Fd -> Fd -> IO ()
gitPushHelper Fd
hin Fd
hout = IO ((), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), ()) -> IO ()) -> IO ((), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
fromstdin IO () -> IO () -> IO ((), ())
forall a b. IO a -> IO b -> IO (a, b)
`concurrently` IO ()
tostdout
  where
	fromstdin :: IO ()
fromstdin = do
		Handle
h <- Fd -> IO Handle
fdToHandle Fd
hout
		Handle
stdin Handle -> Handle -> IO ()
*>* Handle
h
	tostdout :: IO ()
tostdout = do
		Handle
h <- Fd -> IO Handle
fdToHandle Fd
hin
		Handle
h Handle -> Handle -> IO ()
*>* Handle
stdout

-- Forward data from one handle to another.
(*>*) :: Handle -> Handle -> IO ()
Handle
fromh *>* :: Handle -> Handle -> IO ()
*>* Handle
toh = do
	ByteString
b <- Handle -> Int -> IO ByteString
B.hGetSome Handle
fromh Int
40960
	if ByteString -> Bool
B.null ByteString
b
		then do
			Handle -> IO ()
hClose Handle
fromh
			Handle -> IO ()
hClose Handle
toh
		else do
			Handle -> ByteString -> IO ()
B.hPut Handle
toh ByteString
b
			Handle -> IO ()
hFlush Handle
toh
			Handle
fromh Handle -> Handle -> IO ()
*>* Handle
toh