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

make createProcess calls async exception safe

Browse source 
Using cleanupProcess because withCreateProcess cannot run an Annex
action, but the effect is the same as using it.
This commit is contained in:
Joey Hess 2020-06-03 15:23:23 -04:00
parent 31d53587d5
commit 1ee5919d1e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 24 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

28
Remote/Git.hs
View file

@ -469,18 +469,18 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback
P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback P2PHelper.lock withconn Ssh.runProtoConn (uuid r) key callback
| otherwise = failedlock | otherwise = failedlock
where where
fallback = do fallback = withNullHandle $ \nullh -> do
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
repo "lockcontent" repo "lockcontent"
[Param $ serializeKey key] [] [Param $ serializeKey key] []
(Just hin, Just hout, Nothing, p) <- liftIO $ let p = (proc cmd (toCommand params))
withFile devNull WriteMode $ \nullh ->
createProcess $
(proc cmd (toCommand params))
{ std_in = CreatePipe { std_in = CreatePipe
, std_out = CreatePipe , std_out = CreatePipe
, std_err = UseHandle nullh , std_err = UseHandle nullh
} }
bracketIO (createProcess p) cleanupProcess fallback'
fallback' (Just hin, Just hout, Nothing, p) = do
v <- liftIO $ tryIO $ getProtocolLine hout v <- liftIO $ tryIO $ getProtocolLine hout
let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync let signaldone = void $ tryNonAsync $ liftIO $ mapM_ tryNonAsync
[ hPutStrLn hout "" [ hPutStrLn hout ""
@ -507,6 +507,8 @@ lockKey' repo r st@(State connpool duc _ _ _) key callback
showNote "lockcontent failed" showNote "lockcontent failed"
signaldone signaldone
failedlock failedlock
fallback' _ = error "internal"
failedlock = giveup "can't lock content" failedlock = giveup "can't lock content"
{- Tries to copy a key's content from a remote's annex to a file. -} {- Tries to copy a key's content from a remote's annex to a file. -}
@ -587,7 +589,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
repo "transferinfo" repo "transferinfo"
[Param $ serializeKey key] fields [Param $ serializeKey key] fields
v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) v <- liftIO (newEmptySV :: IO (MSampleVar Integer))
pidv <- liftIO $ newEmptyMVar pv <- liftIO $ newEmptyMVar
tid <- liftIO $ forkIO $ void $ tryIO $ do tid <- liftIO $ forkIO $ void $ tryIO $ do
bytes <- readSV v bytes <- readSV v
p <- createProcess $ p <- createProcess $
@ -595,7 +597,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
{ std_in = CreatePipe { std_in = CreatePipe
, std_err = CreatePipe , std_err = CreatePipe
} }
putMVar pidv (processHandle p) putMVar pv p
hClose $ stderrHandle p hClose $ stderrHandle p
let h = stdinHandle p let h = stdinHandle p
let send b = do let send b = do
@ -615,9 +617,17 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met
let cleanup = forkIO $ do let cleanup = forkIO $ do
void $ tryIO $ killThread tid void $ tryIO $ killThread tid
void $ tryNonAsync $ void $ tryNonAsync $
maybe noop (void . waitForProcess) maybe noop (void . waitForProcess . processHandle)
=<< tryTakeMVar pidv =<< tryTakeMVar pv
let forcestop = do
void $ tryIO $ killThread tid
void $ tryNonAsync $
maybe noop cleanupProcess
=<< tryTakeMVar pv
bracketIO noop (const cleanup) (const $ a feeder) bracketIO noop (const cleanup) (const $ a feeder)
`onException` liftIO forcestop
copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
copyFromRemoteCheap r st repo copyFromRemoteCheap r st repo