{-# 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- just a noop
		Just String
b -> do
			String
currentBranch <- IO String
getCurrentBranch
			forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
b forall a. Eq a => a -> a -> Bool
/= String
currentBranch) forall a b. (a -> b) -> a -> b
$
				forall a. HasCallStack => String -> a
error (String
"spin aborted: check out "
					forall a. [a] -> [a] -> [a]
++ String
b 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"
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noDirtySpin forall a b. (a -> b) -> a -> b
$ do
		String
status <- forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"git" [String
"status", String
"--porcelain"]
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ String
status) forall a b. (a -> b) -> a -> b
$
			forall a. HasCallStack => String -> a
error String
"spin aborted: commit changes first"

	forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Git commit" forall a b. (a -> b) -> a -> b
$
		Maybe String -> [CommandParam] -> IO Bool
gitCommit (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.
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasOrigin forall a b. (a -> b) -> a -> b
$
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
"Push to central git repository" 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' 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-A"]
		else [CommandParam] -> [String]
toCommand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [CommandParam]
sshCachingParams String
hn
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
viarelay forall a b. (a -> b) -> a -> b
$
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ String -> [CommandParam] -> IO Bool
boolSystem String
"ssh-add" []

	String
sshtarget <- (String
"root@" forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe String
relay of
		Just String
r -> 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" forall a b. (a -> b) -> a -> b
$ [String]
cacheparams forall a. [a] -> [a] -> [a]
++ [String
sshtarget, String -> String
shellWrap String
probecmd])
		(String -> [String] -> CreateProcess
proc String
"ssh" forall a b. (a -> b) -> a -> b
$ [String]
cacheparams forall a. [a] -> [a] -> [a]
++ [String
sshtarget, String -> String
shellWrap String
updatecmd])
		forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO PrivMap
getprivdata

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

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

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

	runcmd :: String
runcmd = String
"cd " forall a. [a] -> [a] -> [a]
++ String
localdir forall a. [a] -> [a] -> [a]
++ String
" && ./propellor " forall a. [a] -> [a] -> [a]
++ String
cmd
	cmd :: String
cmd = String
"--serialized " forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape (forall a. Show a => a -> String
show CmdLine
cmdline)
	cmdline :: CmdLine
cmdline
		| Bool
viarelay = [String] -> Maybe String -> CmdLine
Spin [String
target] (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
				forall (m :: * -> *) a. Monad m => a -> m a
return PrivMap
d
			| Bool
otherwise ->
				Host -> PrivMap -> PrivMap
filterPrivData Host
hst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO PrivMap
decryptPrivData
		Just PrivMap
pd -> 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
	| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
configips = forall (m :: * -> *) a. Monad m => a -> m a
return String
target
	| Bool
otherwise = forall {a}. Show a => Either a [AddrInfo] -> IO String
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (forall a. Show a => a -> String
show a
e)
	go (Right [AddrInfo]
addrinfos) = do
		[SockAddr]
configaddrinfos <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SockAddr]
configaddrinfos) (forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress [AddrInfo]
addrinfos)
			then 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 " forall a. [a] -> [a] -> [a]
++ 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_CANONNAME] }) (forall a. a -> Maybe a
Just String
h) 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 = forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> SockAddr
addrAddress
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICHOST] })  (forall a. a -> Maybe a
Just String
ip) forall a. Maybe a
Nothing

	useip :: String -> IO String
useip String
why = case forall a. [a] -> Maybe a
headMaybe [String]
configips of
		Maybe String
Nothing -> 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 <- forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO String
readProcess String
"hostname" [String
"-f"]
			if String
s forall a. Eq a => a -> a -> Bool
== String
target
				then forall (m :: * -> *) a. Monad m => a -> m a
return String
target
				else do
					forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ String
"DNS seems out of date for " forall a. [a] -> [a] -> [a]
++ String
target forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
why forall a. [a] -> [a] -> [a]
++ String
"); using IP address from configuration instead."
					forall (m :: * -> *) a. Monad m => a -> m a
return String
ip

	configips :: [String]
configips = forall a b. (a -> b) -> [a] -> [b]
map forall t. ConfigurableValue t => t -> String
val forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Record -> Maybe IPAddr
getIPAddr forall a b. (a -> b) -> a -> b
$
		forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Info -> Set Record
getDnsInfo 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
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasGitRepo 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 forall a b. (a -> b) -> a -> b
$
		String -> String -> IO ()
writeFileProtected String
privfile

	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
hasGitRepo 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 = 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 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> IO ExitCode
waitForProcessNonConcurrent ProcessHandle
pid
  where
	hn :: String
hn = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Maybe Stage
v <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing forall a. Read a => String -> Maybe a
readish 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 (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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
geturl
  where
	geturl :: IO String
geturl = case forall v. InfoVal v -> Maybe v
fromInfoVal (forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
hst)) of
		Maybe OriginUrl
Nothing -> forall a. a -> Maybe a -> a
fromMaybe String
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String)
getRepoUrl
		Just (OriginUrl String
u) -> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage String
msg forall a b. (a -> b) -> a -> b
$ do
	Handle -> String -> String -> IO ()
sendMarked Handle
toh String
privDataMarker String
d
	forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
	msg :: String
msg = String
"Sending privdata (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
d) forall a. [a] -> [a] -> [a]
++ String
" bytes) to " forall a. [a] -> [a] -> [a]
++ String
hn
	d :: String
d = 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 =
	forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage (String
"Sending git update to " forall a. [a] -> [a] -> [a]
++ String
hn) 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
		forall a. Eq a => a -> a -> Bool
(==) ExitCode
ExitSuccess 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
String -> m r -> m r
actionMessage (String
"Clone git repository to " forall a. [a] -> [a] -> [a]
++ String
hn) forall a b. (a -> b) -> a -> b
$ do
	String
branch <- IO String
getCurrentBranch
	[CommandParam]
cacheparams <- String -> IO [CommandParam]
sshCachingParams String
hn
	forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withTmpFile String
"propellor.git" forall a b. (a -> b) -> a -> b
$ \String
tmp Handle
_ -> forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM 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" forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
File String
tmp, String -> CommandParam
Param (String
"root@"forall a. [a] -> [a] -> [a]
++String
hnforall a. [a] -> [a] -> [a]
++String
":"forall a. [a] -> [a] -> [a]
++String
remotebundle)]
		, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"ssh" forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
Param (String
"root@"forall a. [a] -> [a] -> [a]
++String
hn), String -> CommandParam
Param 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
		[ String
"git clone " forall a. [a] -> [a] -> [a]
++ String
remotebundle forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
localdir
		, String
"cd " forall a. [a] -> [a] -> [a]
++ String
localdir
		, String
"git checkout -b " forall a. [a] -> [a] -> [a]
++ String
branch
		, String
"git remote rm origin"
		, String
"rm -f " 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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" forall a b. (a -> b) -> a -> b
$
	forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO String
getWorkingDirectory String -> IO ()
changeWorkingDirectory forall a b. (a -> b) -> a -> b
$ \String
_ ->
		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"
		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"]) forall a b. (a -> b) -> a -> b
$
			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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
localdir String -> String -> String
</> String
bin
		forall (f :: * -> *) a. Functor f => f a -> f ()
void 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
		forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withTmpFile String
"propellor.tar." forall a b. (a -> b) -> a -> b
$ \String
tarball Handle
_ -> forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM 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" forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
File String
tarball, String -> CommandParam
Param (String
"root@"forall a. [a] -> [a] -> [a]
++String
hnforall a. [a] -> [a] -> [a]
++String
":"forall a. [a] -> [a] -> [a]
++String
remotetarball)]
			, String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"ssh" forall a b. (a -> b) -> a -> b
$ [CommandParam]
cacheparams forall a. [a] -> [a] -> [a]
++ [String -> CommandParam
Param (String
"root@"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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
" && "
		[ String
"cd " forall a. [a] -> [a] -> [a]
++ String -> String
takeDirectory String
remotetarball
		, String
"tar xzf " forall a. [a] -> [a] -> [a]
++ String
remotetarball
		, String
"rm -f " 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]
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Maybe String -> [CommandParam] -> IO Bool
gitCommit forall a. Maybe a
Nothing [String -> CommandParam
Param String
"-a", String -> CommandParam
Param String
"--allow-empty"]) forall a b. (a -> b) -> a -> b
$
		forall a. HasCallStack => String -> a
error String
"git commit failed"
	String -> [CommandParam] -> IO ()
rungit String
"merge" 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 = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystem String
"git" (String -> CommandParam
Param String
cmdforall a. a -> [a] -> [a]
:[CommandParam]
ps)) forall a b. (a -> b) -> a -> b
$
		forall a. HasCallStack => String -> a
error (String
"git " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
" failed")

findLastNonSpinCommit :: IO String
findLastNonSpinCommit :: IO String
findLastNonSpinCommit = do
	[(String, String)]
commits <- forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (forall a. Eq a => a -> a -> Bool
== Char
' ')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
		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 forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(String
_, String
msg) -> String
msg forall a. Eq a => a -> a -> Bool
== String
spinCommitMessage) [(String, String)]
commits of
		((String
sha, String
_):[(String, String)]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
sha
		[(String, String)]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Did not find any previous commit that was not a " forall a. [a] -> [a] -> [a]
++ 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 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 <- forall a. IO a -> IO (Async a)
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.
	forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> [CommandParam] -> IO Bool
boolSystemNonConcurrent String
"git" (forall {a} {a}. (Show a, Show a) => a -> a -> [CommandParam]
fetchparams Fd
hin Fd
hout)) forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *) a. MonadIO m => String -> m a
errorMessage String
"git fetch from client failed"
	forall a. Async a -> IO a
wait Async ()
forwarder
	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"]) forall a b. (a -> b) -> a -> b
$
		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 forall a b. (a -> b) -> a -> b
$ String
"./propellor --gitpush " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
hin forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO ()
fromstdin 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