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

fix problem with last commit and assistant

Browse source 
liftAnnex blocks all others calls, so avoid using it with a long-duration
call to readResponse.
This commit is contained in:
Joey Hess 2020-12-04 12:20:04 -04:00
parent cad147cbbf
commit 7a9b618d5d
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 17 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

14
Command/TransferKeys.hs
View file

@ -19,7 +19,6 @@ import qualified Database.Keys
import Annex.BranchState
import Types.Messages
import Types.Key
import Messages.Internal
import Text.Read (readMaybe)
@ -102,6 +101,7 @@ runRequests readh writeh a = go Nothing Nothing
hPutStrLn writeh $ show $ TransferResult b
hFlush writeh
-- FIXME this is bad when used with inAnnex
sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
(transferDirection t)
@ -111,16 +111,14 @@ sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
-- | Read a response from this command.
--
-- Each TransferOutput line that is read before the final TransferResult
-- will be output.
readResponse :: Handle -> Annex Bool
-- Before the final response, this will return whatever SerializedOutput
-- should be displayed as the transfer is performed.
readResponse :: Handle -> IO (Either SerializedOutput Bool)
readResponse h = do
l <- liftIO $ hGetLine h
case readMaybe l of
Just (TransferOutput so) -> do
emitSerializedOutput so
readResponse h
Just (TransferResult r) -> return r
Just (TransferOutput so) -> return (Left so)
Just (TransferResult r) -> return (Right r)
Nothing -> protocolError l
protocolError :: String -> a