Fully asynchronous request handling (haskell/ghcide#767)

* Cancellation of user actions

* Dispatch event handlers asynchronously

* add tests for asynchronous features

This adds a new Test plugin for custom requests
and a new blocking Command

* hlint

* Link the Testing plugin only when --testing

* Fix expectNoMoreDiagnostics

Needs also lukel97/lsp-test#74

* Upgrade lsp-test to a version that understands CustomClientMethod

exe/Main.hs

@@ -30,6 +30,7 @@ import Development.IDE.Types.Logger
 import Development.IDE.Plugin
 import Development.IDE.Plugin.Completions as Completions
 import Development.IDE.Plugin.CodeAction as CodeAction
+import Development.IDE.Plugin.Test as Test
 import Development.IDE.Session
 import qualified Language.Haskell.LSP.Core as LSP
 import Language.Haskell.LSP.Messages
@@ -81,6 +82,7 @@ main = do
     command <- makeLspCommandId "typesignature.add"
 
     let plugins = Completions.plugin <> CodeAction.plugin
+            <> if argsTesting then Test.plugin else mempty
         onInitialConfiguration :: InitializeRequest -> Either T.Text LspConfig
         onInitialConfiguration x = case x ^. params . initializationOptions of
           Nothing -> Right defaultLspConfig

ghcide.cabal

@@ -147,6 +147,7 @@ library
         Development.IDE.Plugin
         Development.IDE.Plugin.Completions
         Development.IDE.Plugin.CodeAction
+        Development.IDE.Plugin.Test
 
     -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
     -- the real GHC library and the types are incompatible. Furthermore, when
@@ -337,7 +338,7 @@ test-suite ghcide-tests
         haskell-lsp-types,
         network-uri,
         lens,
-        lsp-test >= 0.11.0.1 && < 0.12,
+        lsp-test >= 0.11.0.5 && < 0.12,
         optparse-applicative,
         process,
         QuickCheck,

src/Development/IDE/Core/Shake.hs

@@ -567,13 +567,20 @@ shakeRestart IdeState{..} acts =
 --
 --   Appropriate for user actions other than edits.
 shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)
-shakeEnqueue ShakeExtras{actionQueue} act = do
+shakeEnqueue ShakeExtras{actionQueue, logger} act = do
     (b, dai) <- instantiateDelayedAction act
     atomically $ pushQueue dai actionQueue
     let wait' b =
-            waitBarrier b `catch` \BlockedIndefinitelyOnMVar ->
-                fail $ "internal bug: forever blocked on MVar for " <>
-                        actionName act
+            waitBarrier b `catches`
+              [ Handler(\BlockedIndefinitelyOnMVar ->
+                    fail $ "internal bug: forever blocked on MVar for " <>
+                            actionName act)
+              , Handler (\e@AsyncCancelled -> do
+                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"
+
+                  atomically $ abortQueue dai actionQueue
+                  throw e)
+              ]
     return (wait' b >>= either throwIO return)
 
 -- | Set up a new 'ShakeSession' with a set of initial actions

src/Development/IDE/LSP/LanguageServer.hs

@@ -71,6 +71,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
     -- This should not happen but if it does, we will make sure that the whole server
     -- dies and can be restarted instead of losing threads silently.
     clientMsgBarrier <- newBarrier
+    -- Forcefully exit
+    let exit = signalBarrier clientMsgBarrier ()
 
     -- The set of requests ids that we have received but not finished processing
     pendingRequests <- newTVarIO Set.empty
@@ -107,15 +109,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
             setHandlersOutline <>
             userHandlers <>
             setHandlersNotifications <> -- absolutely critical, join them with user notifications
-            cancelHandler cancelRequest
+            cancelHandler cancelRequest <>
+            exitHandler exit
             -- Cancel requests are special since they need to be handled
             -- out of order to be useful. Existing handlers are run afterwards.
     handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
 
     let initializeCallbacks = LSP.InitializeCallbacks
             { LSP.onInitialConfiguration = onInitialConfig
             , LSP.onConfigurationChange = onConfigChange
-            , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
+            , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan
             }
 
     void $ waitAnyCancel =<< traverse async
@@ -137,7 +140,8 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
 
             _ <- flip forkFinally (const exitClientMsg) $ forever $ do
                 msg <- readChan clientMsgChan
-                case msg of
+                -- dispatch the work to a new thread
+                void $ async $ case msg of
                     Notification x@NotificationMessage{_params} act -> do
                         catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
                             logError (ideLogger ide) $ T.pack $
@@ -217,6 +221,9 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
             whenJust (LSP.cancelNotificationHandler x) ($ msg)
     }
 
+exitHandler :: IO () -> PartialHandlers c
+exitHandler exit = PartialHandlers $ \_ x -> return x
+    {LSP.exitNotificationHandler = Just $ const exit}
 
 -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
 --   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

src/Development/IDE/Plugin/CodeAction.hs

@@ -14,7 +14,11 @@ module Development.IDE.Plugin.CodeAction
     , codeAction
     , codeLens
     , rulePackageExports
-    , executeAddSignatureCommand
+    , commandHandler
+
+    -- * For testing
+    , blockCommandId
+    , typeSignatureCommandId
     ) where
 
 import Control.Monad (join, guard)
@@ -58,15 +62,22 @@ import Data.Functor
 import Control.Applicative ((<|>))
 import Safe (atMay)
 import Bag (isEmptyBag)
-import Control.Concurrent.Extra (readVar)
 import qualified Data.HashSet as Set
+import Control.Concurrent.Extra (threadDelay, readVar)
 
 plugin :: Plugin c
 plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
 
 rules :: Rules ()
 rules = rulePackageExports
 
+-- | a command that blocks forever. Used for testing
+blockCommandId :: T.Text
+blockCommandId = "ghcide.command.block"
+
+typeSignatureCommandId :: T.Text
+typeSignatureCommandId = "typesignature.add"
+
 -- | Generate code actions.
 codeAction
     :: LSP.LspFuncs c
@@ -117,17 +128,23 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
       Nothing -> pure []
 
 -- | Execute the "typesignature.add" command.
-executeAddSignatureCommand
+commandHandler
     :: LSP.LspFuncs c
     -> IdeState
     -> ExecuteCommandParams
     -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
-executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
+commandHandler lsp _ideState ExecuteCommandParams{..}
     -- _command is prefixed with a process ID, because certain clients
     -- have a global command registry, and all commands must be
     -- unique. And there can be more than one ghcide instance running
     -- at a time against the same client.
-    | T.isSuffixOf "typesignature.add" _command
+    | T.isSuffixOf blockCommandId _command
+    = do
+        LSP.sendFunc lsp $ NotCustomServer $
+            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
+        threadDelay maxBound
+        return (Right Null, Nothing)
+    | T.isSuffixOf typeSignatureCommandId _command
     , Just (List [edit]) <- _arguments
     , Success wedit <- fromJSON edit
     = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
@@ -1058,8 +1075,13 @@ matchRegex message regex = case message =~~ regex of
 
 setHandlersCodeLens :: PartialHandlers c
 setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
-    LSP.codeLensHandler = withResponse RspCodeLens codeLens,
-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
+    LSP.codeLensHandler =
+        withResponse RspCodeLens codeLens,
+    LSP.executeCommandHandler =
+        withResponseAndRequest
+            RspExecuteCommand
+            ReqApplyWorkspaceEdit
+            commandHandler
     }
 
 filterNewlines :: T.Text -> T.Text

src/Development/IDE/Plugin/Test.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+-- | A plugin that adds custom messages for use in tests
+module Development.IDE.Plugin.Test (TestRequest(..), plugin) where
+
+import Control.Monad.STM
+import Data.Aeson
+import Data.Aeson.Types
+import Development.IDE.Core.Service
+import Development.IDE.Core.Shake
+import Development.IDE.GHC.Compat
+import Development.IDE.GHC.Util (HscEnvEq(hscEnv))
+import Development.IDE.LSP.Server
+import Development.IDE.Plugin
+import Development.IDE.Types.Action
+import GHC.Generics (Generic)
+import GhcPlugins (HscEnv(hsc_dflags))
+import Language.Haskell.LSP.Core
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
+import System.Time.Extra
+import Development.IDE.Core.RuleTypes
+
+data TestRequest
+    = BlockSeconds Seconds           -- ^ :: Null
+    | GetInterfaceFilesDir FilePath  -- ^ :: String
+    | GetShakeSessionQueueCount      -- ^ :: Number
+    deriving Generic
+    deriving anyclass (FromJSON, ToJSON)
+
+plugin :: Plugin c
+plugin = Plugin {
+    pluginRules = return (),
+    pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {
+        customRequestHandler = withResponse RspCustomServer requestHandler'
+    }
+}
+  where
+      requestHandler' lsp ide req
+        | Just customReq <- parseMaybe parseJSON req
+        = requestHandler lsp ide customReq
+        | otherwise
+        = return $ Left
+        $ ResponseError InvalidRequest "Cannot parse request" Nothing
+
+requestHandler :: LspFuncs c
+                -> IdeState
+                -> TestRequest
+                -> IO (Either ResponseError Value)
+requestHandler lsp _ (BlockSeconds secs) = do
+    sendFunc lsp $ NotCustomServer $
+        NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $
+        toJSON secs
+    sleep secs
+    return (Right Null)
+requestHandler _ s (GetInterfaceFilesDir fp) = do
+    let nfp = toNormalizedFilePath fp
+    sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp
+    let hiPath = hiDir $ hsc_dflags $ hscEnv sess
+    return $ Right (toJSON hiPath)
+requestHandler _ s GetShakeSessionQueueCount = do
+    n <- atomically $ countQueue $ actionQueue $ shakeExtras s
+    return $ Right (toJSON n)
+

src/Development/IDE/Types/Action.hs

@@ -7,19 +7,17 @@ module Development.IDE.Types.Action
     popQueue,
     doneQueue,
     peekInProgress,
-  )
+  abortQueue,countQueue)
 where
 
-import           Control.Concurrent.STM       (STM, TQueue, TVar, atomically,
-                                               modifyTVar, newTQueue, newTVar,
-                                               readTQueue, readTVar,
-                                               writeTQueue)
+import           Control.Concurrent.STM
 import           Data.Hashable                (Hashable (..))
 import           Data.HashSet                 (HashSet)
 import qualified Data.HashSet                 as Set
 import           Data.Unique                  (Unique)
 import           Development.IDE.Types.Logger
 import           Development.Shake            (Action)
+import           Numeric.Natural
 
 data DelayedAction a = DelayedAction
   { uniqueID       :: Maybe Unique,
@@ -67,9 +65,24 @@ popQueue ActionQueue {..} = do
   return x
 
 -- | Completely remove an action from the queue
+abortQueue :: DelayedActionInternal -> ActionQueue -> STM ()
+abortQueue x ActionQueue {..} = do
+  qq <- flushTQueue newActions
+  mapM_ (writeTQueue newActions) (filter (/= x) qq)
+  modifyTVar inProgress (Set.delete x)
+
+-- | Mark an action as complete when called after 'popQueue'.
+--   Has no effect otherwise
 doneQueue :: DelayedActionInternal -> ActionQueue -> STM ()
-doneQueue x ActionQueue {..} =
+doneQueue x ActionQueue {..} = do
   modifyTVar inProgress (Set.delete x)
 
+countQueue :: ActionQueue -> STM Natural
+countQueue ActionQueue{..} = do
+    backlog <- flushTQueue newActions
+    mapM_ (writeTQueue newActions) backlog
+    m <- Set.size <$> readTVar inProgress
+    return $ fromIntegral $ length backlog + m
+
 peekInProgress :: ActionQueue -> STM [DelayedActionInternal]
 peekInProgress ActionQueue {..} = Set.toList <$> readTVar inProgress

stack-ghc-lib.yaml

@@ -4,7 +4,7 @@ packages:
 extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
-- lsp-test-0.11.0.2
+- lsp-test-0.11.0.5
 - extra-1.7.2
 - hie-bios-0.6.1
 - ghc-lib-parser-8.8.1

stack.yaml

@@ -4,7 +4,7 @@ packages:
 extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
-- lsp-test-0.11.0.2
+- lsp-test-0.11.0.5
 - hie-bios-0.6.1
 - fuzzy-0.1.0.0
 - regex-pcre-builtin-0.95.1.1.8.43

stack810.yaml

@@ -5,7 +5,7 @@ packages:
 extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
-- lsp-test-0.11.0.2
+- lsp-test-0.11.0.5
 - ghc-check-0.5.0.1
 - hie-bios-0.6.1
 

stack84.yaml

@@ -7,7 +7,7 @@ extra-deps:
 - base-orphans-0.8.2
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
-- lsp-test-0.11.0.2
+- lsp-test-0.11.0.5
 - rope-utf16-splay-0.3.1.0
 - filepattern-0.1.1
 - js-dgtable-0.5.2

stack88.yaml

@@ -4,7 +4,7 @@ packages:
 extra-deps:
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
-- lsp-test-0.11.0.2
+- lsp-test-0.11.0.5
 - ghc-check-0.5.0.1
 - hie-bios-0.6.1
 - extra-1.7.2