remove some unncessary uses of warningIO

warningIO is not concurrent output safe, and it doesn't go to
--json-error-messages

There are a few more that would be too hard to remove, and there are also
several dozen direct prints to stderr still.
This commit is contained in:
Joey Hess 2019-11-12 10:07:27 -04:00
parent 0be23bae2f
commit 9e8d40181f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 15 additions and 15 deletions

View file

@ -183,7 +183,7 @@ runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
runHandler handler file filestatus = void $ do runHandler handler file filestatus = void $ do
r <- tryIO <~> handler (normalize file) filestatus r <- tryIO <~> handler (normalize file) filestatus
case r of case r of
Left e -> liftIO $ warningIO $ show e Left e -> liftAnnex $ warning $ show e
Right Nothing -> noop Right Nothing -> noop
Right (Just change) -> recordChange change Right (Just change) -> recordChange change
where where

View file

@ -286,7 +286,7 @@ setupRepo gcryptid r
{- Ask git-annex-shell to configure the repository as a gcrypt {- Ask git-annex-shell to configure the repository as a gcrypt
- repository. May fail if it is too old. -} - repository. May fail if it is too old. -}
gitannexshellsetup = Ssh.onRemote NoConsumeStdin r gitannexshellsetup = Ssh.onRemote NoConsumeStdin r
(boolSystem, return False) (\f p -> liftIO (boolSystem f p), return False)
"gcryptsetup" [ Param gcryptid ] [] "gcryptsetup" [ Param gcryptid ] []
denyNonFastForwards = "receive.denyNonFastForwards" denyNonFastForwards = "receive.denyNonFastForwards"
@ -451,7 +451,7 @@ getGCryptId fast r gc
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
liftIO (catchMaybeIO $ Git.Config.read r) liftIO (catchMaybeIO $ Git.Config.read r)
| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>) | not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
[ Ssh.onRemote NoConsumeStdin r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p), return (Left $ error "configlist failed")) "configlist" [] []
, getConfigViaRsync r gc , getConfigViaRsync r gc
] ]
| otherwise = return (Nothing, r) | otherwise = return (Nothing, r)

View file

@ -249,21 +249,21 @@ tryGitConfigRead autoinit r
haveconfig = not . M.null . Git.config haveconfig = not . M.null . Git.config
pipedconfig cmd params = do pipedconfig cmd params = do
v <- Git.Config.fromPipe r cmd params v <- liftIO $ Git.Config.fromPipe r cmd params
case v of case v of
Right (r', val) -> do Right (r', val) -> do
unless (isUUIDConfigured r' || null val) $ do unless (isUUIDConfigured r' || null val) $ do
warningIO $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r
warningIO $ "Instead, got: " ++ show val warning $ "Instead, got: " ++ show val
warningIO $ "This is unexpected; please check the network transport!" warning $ "This is unexpected; please check the network transport!"
return $ Right r' return $ Right r'
Left l -> return $ Left l Left l -> return $ Left l
geturlconfig = Url.withUrlOptions $ \uo -> do geturlconfig = Url.withUrlOptions $ \uo -> do
v <- liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do
hClose h liftIO $ hClose h
let url = Git.repoLocation r ++ "/config" let url = Git.repoLocation r ++ "/config"
ifM (Url.downloadQuiet nullMeterUpdate url tmpfile uo) ifM (liftIO $ Url.downloadQuiet nullMeterUpdate url tmpfile uo)
( Just <$> pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] ( Just <$> pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
, return Nothing , return Nothing
) )

View file

@ -83,7 +83,7 @@ git_annex_shell cs r command params fields
onRemote onRemote
:: ConsumeStdin :: ConsumeStdin
-> Git.Repo -> Git.Repo
-> (FilePath -> [CommandParam] -> IO a, Annex a) -> (FilePath -> [CommandParam] -> Annex a, Annex a)
-> String -> String
-> [CommandParam] -> [CommandParam]
-> [(Field, String)] -> [(Field, String)]
@ -91,7 +91,7 @@ onRemote
onRemote cs r (with, errorval) command params fields = do onRemote cs r (with, errorval) command params fields = do
s <- git_annex_shell cs r command params fields s <- git_annex_shell cs r command params fields
case s of case s of
Just (c, ps) -> liftIO $ with c ps Just (c, ps) -> with c ps
Nothing -> errorval Nothing -> errorval
{- Checks if a remote contains a key. -} {- Checks if a remote contains a key. -}
@ -100,14 +100,14 @@ inAnnex r k = do
showChecking r showChecking r
onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] [] onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ serializeKey k] []
where where
runcheck c p = dispatch =<< safeSystem c p runcheck c p = liftIO $ dispatch =<< safeSystem c p
dispatch ExitSuccess = return True dispatch ExitSuccess = return True
dispatch (ExitFailure 1) = return False dispatch (ExitFailure 1) = return False
dispatch _ = cantCheck r dispatch _ = cantCheck r
{- Removes a key from a remote. -} {- Removes a key from a remote. -}
dropKey :: Git.Repo -> Key -> Annex Bool dropKey :: Git.Repo -> Key -> Annex Bool
dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" dropKey r key = onRemote NoConsumeStdin r (\f p -> liftIO (boolSystem f p), return False) "dropkey"
[ Param "--quiet", Param "--force" [ Param "--quiet", Param "--force"
, Param $ serializeKey key , Param $ serializeKey key
] ]

View file

@ -69,7 +69,7 @@ server ichan th@(TransportHandle (LocalRepo r) _) = go
) )
unless ok $ do unless ok $ do
hClose conn hClose conn
warningIO "dropped Tor connection, too busy" liftAnnex th $ warning "dropped Tor connection, too busy"
handlecontrol servicerunning = do handlecontrol servicerunning = do
msg <- atomically $ readTChan ichan msg <- atomically $ readTChan ichan