summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Propellor/Protocol.hs10
-rw-r--r--src/Propellor/Spin.hs38
2 files changed, 33 insertions, 15 deletions
diff --git a/src/Propellor/Protocol.hs b/src/Propellor/Protocol.hs
index ae7e0404..e90155f3 100644
--- a/src/Propellor/Protocol.hs
+++ b/src/Propellor/Protocol.hs
@@ -53,11 +53,7 @@ sendMarked' h marker s = do
hFlush h
getMarked :: Handle -> Marker -> IO (Maybe String)
-getMarked h marker = do
- -- Avoid buffering anything in Handle, so that the data after
- -- the marker will be available to be read from the underlying Fd.
- hSetBuffering stdin NoBuffering
- go =<< catchMaybeIO (hGetLine h)
+getMarked h marker = go =<< catchMaybeIO (hGetLine h)
where
go Nothing = return Nothing
go (Just l) = case fromMarked marker l of
@@ -69,8 +65,8 @@ getMarked h marker = do
debug ["received marked", marker]
return (Just v)
-reqMarked :: Stage -> Marker -> (String -> IO ()) -> IO ()
-reqMarked stage marker a = do
+req :: Stage -> Marker -> (String -> IO ()) -> IO ()
+req stage marker a = do
debug ["requested marked", marker]
sendMarked' stdout statusMarker (show stage)
maybe noop a =<< getMarked stdin marker
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 7146ad4c..6b6c6d69 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -181,11 +181,11 @@ getSshTarget target hst
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
- reqMarked NeedRepoUrl repoUrlMarker setRepoUrl
+ req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
- reqMarked NeedPrivData privDataMarker $
+ req NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
@@ -353,18 +353,25 @@ spinCommitMessage = "propellor spin"
-- Request that it run git upload-pack, and connect that up to a git fetch
-- to receive the data.
gitPullFromUpdateServer :: IO ()
-gitPullFromUpdateServer = reqMarked NeedGitPush gitPushMarker $ \_ -> do
- -- Note that this relies on data not being buffered in the stdin
- -- Handle, since such buffered data would not be available in the
- -- FD passed to git fetch.
- hin <- dup stdInput
+gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> 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.
+ (pread, pwrite) <- System.Posix.IO.createPipe
+ hwrite <- fdToHandle pwrite
+ forwarder <- async $ stdin *>*! hwrite
+ let hin = pread
hout <- dup stdOutput
- hClose stdin
hClose stdout
-- Not using git pull because git 2.5.0 badly
-- broke its option parser.
unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
errorMessage "git fetch from client failed"
+ wait forwarder
unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where
@@ -401,3 +408,18 @@ fromh *>* toh = do
B.hPut toh b
hFlush toh
fromh *>* toh
+
+(*>*!) :: Handle -> Handle -> IO ()
+fromh *>*! toh = do
+ b <- B.hGetSome fromh 40960
+ if B.null b
+ then do
+ hPutStrLn stderr "EOF on forwarded input"
+ hClose fromh
+ hClose toh
+ else do
+ hPutStrLn stderr "forwarding input:"
+ B.hPut stderr b
+ B.hPut toh b
+ hFlush toh
+ fromh *>*! toh