Fix race condition in shakeRun (#80)

* Fix race condition in shakeRun

fixes #79 which also contains a detailed description of the issue.

* Factor out async exception logic into withMVar'

Author: cocreature

src/Development/IDE/Core/Shake.hs

@@ -216,7 +216,7 @@ type IdeRule k v =
 --   mappings from @(FilePath, k)@ to @RuleResult k@.
 data IdeState = IdeState
     {shakeDb :: ShakeDatabase
-    ,shakeAbort :: Var (IO ()) -- close whoever was running last
+    ,shakeAbort :: MVar (IO ()) -- close whoever was running last
     ,shakeClose :: IO ()
     ,shakeExtras :: ShakeExtras
     ,shakeProfileDir :: Maybe FilePath
@@ -298,7 +298,7 @@ shakeOpen eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts
                 , shakeProgress = if reportProgress then lspShakeProgress eventer else const (pure ())
                 }
             rules
-    shakeAbort <- newVar $ return ()
+    shakeAbort <- newMVar $ return ()
     shakeDb <- shakeDb
     return IdeState{..}
 
@@ -336,31 +336,47 @@ shakeProfile :: IdeState -> FilePath -> IO ()
 shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
 
 shakeShut :: IdeState -> IO ()
-shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
+shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
     -- Shake gets unhappy if you try to close when there is a running
     -- request so we first abort that.
     stop
     shakeClose
 
+-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
+-- an exception, the previous value is restored while the second argument is executed masked.
+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
+withMVar' var unmasked masked = mask $ \restore -> do
+    a <- takeMVar var
+    b <- restore (unmasked a) `onException` putMVar var a
+    (a', c) <- masked b
+    putMVar var a'
+    pure c
+
 -- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
 shakeRun :: IdeState -> [Action a] -> IO (IO [a])
--- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
---        not even start, which would make issues with async exceptions less problematic.
-shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
-    (stopTime,_) <- duration stop
-    logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
-    bar <- newBarrier
-    start <- offsetTime
-    thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
-        runTime <- start
-        let res' = case res of
-                Left e -> "exception: " <> displayException e
-                Right _ -> "completed"
-        logDebug logger $ T.pack $
-            "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
-        signalBarrier bar res
-    -- important: we send an async exception to the thread, then wait for it to die, before continuing
-    return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
+shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
+    withMVar'
+        shakeAbort
+        (\stop -> do
+              (stopTime,_) <- duration stop
+              logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
+              bar <- newBarrier
+              start <- offsetTime
+              pure (start, bar))
+        -- It is crucial to be masked here, otherwise we can get killed
+        -- between spawning the new thread and updating shakeAbort.
+        -- See https://github.com/digital-asset/ghcide/issues/79
+        (\(start, bar) -> do
+              thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
+                  runTime <- start
+                  let res' = case res of
+                          Left e -> "exception: " <> displayException e
+                          Right _ -> "completed"
+                  logDebug logger $ T.pack $
+                      "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
+                  signalBarrier bar res
+              -- important: we send an async exception to the thread, then wait for it to die, before continuing
+              pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
 
 getDiagnostics :: IdeState -> IO [FileDiagnostic]
 getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

src/Development/IDE/LSP/CodeAction.hs

@@ -143,6 +143,7 @@ suggestAction contents Diagnostic{_range=_range@Range{..},..}
 
 suggestAction _ _ = []
 
+topOfHoleFitsMarker :: T.Text
 topOfHoleFitsMarker =
 #if MIN_GHC_API_VERSION(8,6,0)
   "Valid hole fits include"