run the file browser in a separate thread to avoid blocking the browser

This commit is contained in:
Joey Hess 2012-08-03 10:18:57 -04:00
parent 02556b5acd
commit 89120261e0

View file

@ -28,6 +28,7 @@ import qualified Git
import Yesod import Yesod
import Text.Hamlet import Text.Hamlet
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent
{- A display of currently running and queued transfers. {- A display of currently running and queued transfers.
- -
@ -104,13 +105,19 @@ getFileBrowserR = whenM openFileBrowser $ do
{- Opens the system file browser on the repo, or, as a fallback, {- Opens the system file browser on the repo, or, as a fallback,
- goes to a file:// url. Returns True if it's ok to redirect away - goes to a file:// url. Returns True if it's ok to redirect away
- from the page (ie, the system file browser was opened). -} - from the page (ie, the system file browser was opened).
-
- Note that the command is opened using a different thread, to avoid
- blocking the response to the browser on it. -}
openFileBrowser :: Handler Bool openFileBrowser :: Handler Bool
openFileBrowser = do openFileBrowser = do
path <- runAnnex (error "no configured repository") $ path <- runAnnex (error "no configured repository") $
fromRepo Git.repoPath fromRepo Git.repoPath
ifM (liftIO $ inPath cmd <&&> boolSystem cmd [File path]) ifM (liftIO $ inPath cmd <&&> inPath cmd)
( return True ( do
void $ liftIO $ forkIO $ void $
boolSystem cmd [Param path]
return True
, do , do
clearUltDest clearUltDest
setUltDest $ "file://" ++ path setUltDest $ "file://" ++ path