{-# 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
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 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")
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"]
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
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
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))
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
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
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
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 :: 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
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
}
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
]
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"
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
(Fd
pread, Fd
pwrite) <- IO (Fd, Fd)
System.Posix.IO.createPipe
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
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
"."
]
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
(*>*) :: 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