Skip to content

Commit

Permalink
Fully asynchronous request handling (haskell/ghcide#767)
Browse files Browse the repository at this point in the history
* 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
  • Loading branch information
pepeiborra committed Sep 7, 2020
1 parent b1d2953 commit 97ac6b5
Show file tree
Hide file tree
Showing 14 changed files with 178 additions and 30 deletions.
2 changes: 2 additions & 0 deletions ghcide/exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion ghcide/ghcide.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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,
Expand Down
15 changes: 11 additions & 4 deletions ghcide/src/Development/IDE/Core/Shake.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
13 changes: 10 additions & 3 deletions ghcide/src/Development/IDE/LSP/LanguageServer.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 $
Expand Down Expand Up @@ -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)
Expand Down
36 changes: 29 additions & 7 deletions ghcide/src/Development/IDE/Plugin/CodeAction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,11 @@ module Development.IDE.Plugin.CodeAction
, codeAction
, codeLens
, rulePackageExports
, executeAddSignatureCommand
, commandHandler

-- * For testing
, blockCommandId
, typeSignatureCommandId
) where

import Control.Monad (join, guard)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand Down
64 changes: 64 additions & 0 deletions ghcide/src/Development/IDE/Plugin/Test.hs
Original file line number Diff line number Diff line change
@@ -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)

25 changes: 19 additions & 6 deletions ghcide/src/Development/IDE/Types/Action.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
2 changes: 1 addition & 1 deletion ghcide/stack.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
36 changes: 34 additions & 2 deletions ghcide/test/exe/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,6 +55,8 @@ import Test.Tasty.Ingredients.Rerun
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import System.Time.Extra
import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId)
import Development.IDE.Plugin.Test (TestRequest(BlockSeconds))

main :: IO ()
main = do
Expand Down Expand Up @@ -90,6 +92,7 @@ main = do
, ifaceTests
, bootTests
, rootUriTests
, asyncTests
]

initializeResponseTests :: TestTree
Expand Down Expand Up @@ -127,7 +130,7 @@ initializeResponseTests = withResource acquire release tests where
, chk "NO doc link" _documentLinkProvider Nothing
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
, chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
, chk "NO experimental" _experimental Nothing
] where
Expand Down Expand Up @@ -3152,6 +3155,35 @@ rootUriTests = testCase "use rootUri" . withoutStackEnv . runTest "dirA" "dirB"
runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()
runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 (s dir)

-- | Test if ghcide asynchronously handles Commands and user Requests
asyncTests :: TestTree
asyncTests = testGroup "async"
[
testSession "command" $ do
-- Execute a command that will block forever
let req = ExecuteCommandParams blockCommandId Nothing Nothing
void $ sendRequest WorkspaceExecuteCommand req
-- Load a file and check for code actions. Will only work if the command is run asynchronously
doc <- createDoc "A.hs" "haskell" $ T.unlines
[ "{-# OPTIONS -Wmissing-signatures #-}"
, "foo = id"
]
void waitForDiagnostics
actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))
liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
, testSession "request" $ do
-- Execute a custom request that will block for 1000 seconds
void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000
-- Load a file and check for code actions. Will only work if the request is run asynchronously
doc <- createDoc "A.hs" "haskell" $ T.unlines
[ "{-# OPTIONS -Wmissing-signatures #-}"
, "foo = id"
]
void waitForDiagnostics
actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))
liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
]

----------------------------------------------------------------------
-- Utils
----------------------------------------------------------------------
Expand Down Expand Up @@ -3239,7 +3271,7 @@ runInDir' dir startExeIn startSessionIn s = do
-- If you uncomment this you can see all logging
-- which can be quite useful for debugging.
-- { logStdErr = True, logColor = False }
-- If you really want to, you can also see all messages
-- If you really want to, you can also see all messages
-- { logMessages = True, logColor = False }

openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
Expand Down
4 changes: 2 additions & 2 deletions ghcide/test/src/Development/IDE/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -70,9 +70,9 @@ expectNoMoreDiagnostics timeout = do
"Got unexpected diagnostics for " <> show fileUri <>
" got " <> show actual
handleCustomMethodResponse =
-- the CustomClientMethod triggers a log message about ignoring it
-- the CustomClientMethod triggers a RspCustomServer
-- handle that and then exit
void (LspTest.message :: Session LogMessageNotification)
void (LspTest.message :: Session CustomResponse)
ignoreOthers = void anyMessage >> handleMessages

expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
Expand Down
Loading

0 comments on commit 97ac6b5

Please sign in to comment.