close stdin handles before waiting on commands

Fixes reversion in recent conversions, the old code relied on the GC
apparently, but the new code explicitly waits on the process, so must
close stdin handle first or the command will never exit.
This commit is contained in:
Joey Hess 2020-06-05 17:27:49 -04:00
parent ef0024444b
commit e41f8c83f3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 7 additions and 7 deletions

View file

@ -103,15 +103,15 @@ pipeWriteRead params writer repo = assertLocal repo $
{- Runs a git command, feeding it input on a handle with an action. -}
pipeWrite :: [CommandParam] -> Repo -> (Handle -> IO ()) -> IO ()
pipeWrite params repo a = assertLocal repo $
pipeWrite params repo feeder = assertLocal repo $
let p = (gitCreateProcess params repo)
{ std_in = CreatePipe }
in withCreateProcess p (go p)
where
go p (Just hin) _ _ pid =
go p (Just hin) _ _ pid = do
feeder hin
hClose hin
forceSuccessProcess p pid
`after`
a hin
go _ _ _ _ _ = error "internal"
{- Reads null terminated output of a git command (as enabled by the -z

View file

@ -166,10 +166,10 @@ store' r k b p = go =<< glacierEnv c gc u
let cmd = (proc "glacier" (toCommand params)) { env = Just e }
{ std_in = CreatePipe }
in liftIO $ withCreateProcess cmd (go' cmd)
go' cmd (Just hin) _ _ pid =
forceSuccessProcess cmd pid
`after`
go' cmd (Just hin) _ _ pid = do
meteredWrite p hin b
hClose hin
forceSuccessProcess cmd pid
go' _ _ _ _ _ = error "internal"
retrieve :: Remote -> Retriever