    {-# Language ScopedTypeVariables #-}

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

    import Data.List
    import System.Exit
    import System.Posix
    import System.Posix.IO
    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 a. a -> IO a
    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 a. [a] -> 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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    configips = String -> IO String
    forall a. a -> IO a
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. Eq a => a -> [a] -> 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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a. [a] -> 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 a. a -> IO a
    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