mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

convert git config reading to use hGetLineUntilExitOrEOF

Browse source 
Much nicer than the old hack of waiting for a few seconds for stderr to be read.
This commit is contained in:
Joey Hess 2020-11-19 15:34:26 -04:00
parent 04dca96710
commit 66497d39b3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 10 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
Git/Config.hs
View file

@ -22,7 +22,6 @@ import Git.Types
import qualified Git.Command
import qualified Git.Construct
import Utility.UserInfo
import Utility.ThreadScheduler
{- Returns a single git config setting, or a fallback value if not set. -}
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
@ -211,8 +210,8 @@ coreBare = "core.bare"
{- Runs a command to get the configuration of a repo,
- and returns a repo populated with the configuration, as well as the raw
- output and standard error of the command. -}
fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))
- output and the standard error of the command. -}
fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String))
fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go
where
p = (proc cmd $ toCommand params)
@ -220,24 +219,21 @@ fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go
, std_err = CreatePipe
}
go _ (Just hout) (Just herr) pid =
withAsync (S.hGetContents herr) $ \errreader -> do
withAsync (getstderr pid herr []) $ \errreader -> do
val <- S.hGetContents hout
-- In case the process exits while something else,
-- like a background process, keeps the stderr handle
-- open, don't block forever waiting for stderr.
-- A few seconds after finishing reading stdout
-- should get any error message.
err <- either id id <$>
wait errreader
`race` (threadDelaySeconds (Seconds 2) >> return mempty)
err <- wait errreader
forceSuccessProcess p pid
r' <- store val st r
return (r', val, err)
go _ _ _ _ = error "internal"
getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case
Just l -> getstderr pid herr (l:c)
Nothing -> return (unlines (reverse c))
{- Reads git config from a specified file and returns the repo populated
- with the configuration. -}
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString))
fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String))
fromFile r f = fromPipe r "git"
[ Param "config"
, Param "--file"

2
Remote/GCrypt.hs
View file

@ -487,7 +487,7 @@ getGCryptId fast r gc
extract Nothing = (Nothing, r)
extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r')
getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, S.ByteString))
getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, String))
getConfigViaRsync r gc = do
(rsynctransport, rsyncurl, _) <- rsyncTransport r gc
opts <- rsynctransport