haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-02 14:20:25 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Better compressor-status termination messages

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-18 18:37:20 +02:00
parent cce7fb3ddf
commit 894f428a5b
1 changed files with 7 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Handler/Haddock.hs
View File

@ -94,13 +94,19 @@ createCompressor
createCompressor dirs = do createCompressor dirs = do
baton <- newMVar () baton <- newMVar ()
status <- newIORef "Compressor is idle" status <- newIORef "Compressor is idle"
mask_ $ void $ forkIO $ (`finally` writeIORef status "Compressor thread exited") $ forever $ do mask_ $ void $ forkIO $ (finallyE $ \e -> writeIORef status $ "Compressor thread exited: " ++ tshow e) $ forever $ do
writeIORef status "Waiting for signal to start compressing" writeIORef status "Waiting for signal to start compressing"
takeMVar baton takeMVar baton
writeIORef status "Received signal, traversing directories" writeIORef status "Received signal, traversing directories"
runResourceT $ goDir status (dirRawRoot dirs) runResourceT $ goDir status (dirRawRoot dirs)
return (status, void $ tryPutMVar baton ()) return (status, void $ tryPutMVar baton ())
where where
finallyE f g = mask $ \restore -> do
restore g `catch` \e -> do
() <- f $ Just (e :: SomeException)
() <- throwIO e
return ()
f Nothing
goDir status dir = do goDir status dir = do
writeIORef status $ "Compressing directory: " ++ fpToText dir writeIORef status $ "Compressing directory: " ++ fpToText dir
sourceDirectory dir $$ mapM_C (goFP status) sourceDirectory dir $$ mapM_C (goFP status)