Skip to content

Commit 242644d

Browse files
michaelpjmichaelpj
authored
Various fixes to progress handling (#539)
* Various fixes to progress handling 1. Server-initiated progress should wait for the client to acknowledge This is an old bug. Per the spec, we're not allowed to send any reports using the token if the client doesn't respond with a non-error response to our creation of the token. This is a bit subtle, because it means we may need to delay the sending of the "begin" notification until we have received the token from the client. 2. No easy way to use client-initiated progress This is simpler and faster than server-initiated progress since you don't need the extra message round-trip. You just need to pull out the progress token (if there is one) from the request and use that. I did two things to make this better: - The progress functions now take the client token if there is one. If there isn't one they still fall back to server-initiated progress. - The server capabilities can now advertise that client-initiated progress is supported. * Make the default for client-initiated progress to be off * Don't lose progress updates if it takes a while to start * Refactor tests * Add test for cancellation * Fix minor bug in lsp-test config handling * More tests * Try this * Fix formatting * Add comment and purge traces
1 parent 847c239 commit 242644d

File tree

7 files changed

+536
-229
lines changed

7 files changed

+536
-229
lines changed

‎lsp-test/func-test/FuncTest.hs

Lines changed: 202 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,24 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE GADTs #-}
23
{-# LANGUAGE OverloadedStrings #-}
34
{-# LANGUAGE RankNTypes #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE ViewPatterns #-}
48

59
module Main where
610

11+
import Colog.Core
712
import Colog.Core qualified as L
813
import Control.Applicative.Combinators
914
import Control.Exception
1015
import Control.Lens hiding (Iso, List)
1116
import Control.Monad
1217
import Control.Monad.IO.Class
18+
import Data.Aeson qualified as J
1319
import Data.Maybe
20+
import Data.Proxy
21+
import Data.Set qualified as Set
1422
import Language.LSP.Protocol.Lens qualified as L
1523
import Language.LSP.Protocol.Message
1624
import Language.LSP.Protocol.Types
@@ -23,14 +31,138 @@ import Test.Hspec
2331
import UnliftIO
2432
import UnliftIO.Concurrent
2533

26-
main :: IO ()
27-
main = hspec $ do
34+
runSessionWithServer ::
35+
LogAction IO (WithSeverity LspServerLog) ->
36+
ServerDefinition config ->
37+
Test.SessionConfig ->
38+
ClientCapabilities ->
39+
FilePath ->
40+
Test.Session a ->
41+
IO a
42+
runSessionWithServer logger defn testConfig caps root session = do
43+
(hinRead, hinWrite) <- createPipe
44+
(houtRead, houtWrite) <- createPipe
45+
46+
server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite defn
47+
48+
res <- Test.runSessionWithHandles hinWrite houtRead testConfig caps root session
49+
50+
timeout 3000000 $ do
51+
Left (fromException -> Just ExitSuccess) <- waitCatch server
52+
pure ()
53+
54+
pure res
55+
56+
spec :: Spec
57+
spec = do
2858
let logger = L.cmap show L.logStringStderr
29-
describe "progress reporting" $
30-
it "sends end notification if thread is killed" $ do
31-
(hinRead, hinWrite) <- createPipe
32-
(houtRead, houtWrite) <- createPipe
59+
describe "server-initiated progress reporting" $ do
60+
it "sends updates" $ do
61+
startBarrier <- newEmptyMVar
62+
63+
let definition =
64+
ServerDefinition
65+
{ parseConfig = const $ const $ Right ()
66+
, onConfigChange = const $ pure ()
67+
, defaultConfig = ()
68+
, configSection = "demo"
69+
, doInitialize = \env _req -> pure $ Right env
70+
, staticHandlers = \_caps -> handlers
71+
, interpretHandler = \env -> Iso (runLspT env) liftIO
72+
, options = defaultOptions
73+
}
74+
75+
handlers :: Handlers (LspM ())
76+
handlers =
77+
requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do
78+
withProgress "Doing something" Nothing NotCancellable $ \updater -> do
79+
takeMVar startBarrier
80+
updater $ ProgressAmount (Just 25) (Just "step1")
81+
updater $ ProgressAmount (Just 50) (Just "step2")
82+
updater $ ProgressAmount (Just 75) (Just "step3")
83+
84+
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
85+
Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
86+
87+
-- Wait until we have seen a begin messsage. This means that the token setup
88+
-- has happened and the server has been able to send us a begin message
89+
skipManyTill Test.anyMessage $ do
90+
x <- Test.message SMethod_Progress
91+
guard $ has (L.params . L.value . _workDoneProgressBegin) x
92+
93+
-- allow the hander to send us updates
94+
putMVar startBarrier ()
95+
96+
do
97+
u <- Test.message SMethod_Progress
98+
liftIO $ do
99+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
100+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
101+
102+
do
103+
u <- Test.message SMethod_Progress
104+
liftIO $ do
105+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
106+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
107+
108+
do
109+
u <- Test.message SMethod_Progress
110+
liftIO $ do
111+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
112+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
113+
114+
-- Then make sure we get a $/progress end notification
115+
skipManyTill Test.anyMessage $ do
116+
x <- Test.message SMethod_Progress
117+
guard $ has (L.params . L.value . _workDoneProgressEnd) x
118+
119+
it "handles cancellation" $ do
120+
wasCancelled <- newMVar False
121+
122+
let definition =
123+
ServerDefinition
124+
{ parseConfig = const $ const $ Right ()
125+
, onConfigChange = const $ pure ()
126+
, defaultConfig = ()
127+
, configSection = "demo"
128+
, doInitialize = \env _req -> pure $ Right env
129+
, staticHandlers = \_caps -> handlers
130+
, interpretHandler = \env -> Iso (runLspT env) liftIO
131+
, options = defaultOptions
132+
}
133+
134+
handlers :: Handlers (LspM ())
135+
handlers =
136+
requestHandler (SMethod_CustomMethod (Proxy @"something")) $ \_req resp -> void $ forkIO $ do
137+
-- Doesn't matter what cancellability we set here!
138+
withProgress "Doing something" Nothing NotCancellable $ \updater -> do
139+
-- Wait around to be cancelled, set the MVar only if we are
140+
liftIO $ threadDelay (1 * 1000000) `Control.Exception.catch` (\(e :: ProgressCancelledException) -> modifyMVar_ wasCancelled (\_ -> pure True))
141+
142+
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
143+
Test.sendRequest (SMethod_CustomMethod (Proxy @"something")) J.Null
144+
145+
-- Wait until we have created the progress so the updates will be sent individually
146+
token <- skipManyTill Test.anyMessage $ do
147+
x <- Test.message SMethod_WindowWorkDoneProgressCreate
148+
pure $ x ^. L.params . L.token
33149

150+
-- First make sure that we get a $/progress begin notification
151+
skipManyTill Test.anyMessage $ do
152+
x <- Test.message SMethod_Progress
153+
guard $ has (L.params . L.value . _workDoneProgressBegin) x
154+
155+
Test.sendNotification SMethod_WindowWorkDoneProgressCancel (WorkDoneProgressCancelParams token)
156+
157+
-- Then make sure we still get a $/progress end notification
158+
skipManyTill Test.anyMessage $ do
159+
x <- Test.message SMethod_Progress
160+
guard $ has (L.params . L.value . _workDoneProgressEnd) x
161+
162+
c <- readMVar wasCancelled
163+
c `shouldBe` True
164+
165+
it "sends end notification if thread is killed" $ do
34166
killVar <- newEmptyMVar
35167

36168
let definition =
@@ -47,19 +179,13 @@ main = hspec $ do
47179

48180
handlers :: MVar () -> Handlers (LspM ())
49181
handlers killVar =
50-
notificationHandler SMethod_Initialized $ \noti -> do
51-
tid <- withRunInIO $ \runInIO ->
52-
forkIO $
53-
runInIO $
54-
withProgress "Doing something" NotCancellable $ \updater ->
55-
liftIO $ threadDelay (1 * 1000000)
56-
liftIO $ void $ forkIO $ do
57-
takeMVar killVar
58-
killThread tid
59-
60-
forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
61-
62-
Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do
182+
notificationHandler SMethod_Initialized $ \noti -> void $
183+
forkIO $
184+
withProgress "Doing something" Nothing NotCancellable $ \updater -> liftIO $ do
185+
takeMVar killVar
186+
Control.Exception.throwIO AsyncCancelled
187+
188+
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
63189
-- First make sure that we get a $/progress begin notification
64190
skipManyTill Test.anyMessage $ do
65191
x <- Test.message SMethod_Progress
@@ -73,11 +199,61 @@ main = hspec $ do
73199
x <- Test.message SMethod_Progress
74200
guard $ has (L.params . L.value . _workDoneProgressEnd) x
75201

202+
describe "client-initiated progress reporting" $ do
203+
it "sends updates" $ do
204+
let definition =
205+
ServerDefinition
206+
{ parseConfig = const $ const $ Right ()
207+
, onConfigChange = const $ pure ()
208+
, defaultConfig = ()
209+
, configSection = "demo"
210+
, doInitialize = \env _req -> pure $ Right env
211+
, staticHandlers = \_caps -> handlers
212+
, interpretHandler = \env -> Iso (runLspT env) liftIO
213+
, options = defaultOptions{optSupportClientInitiatedProgress = True}
214+
}
215+
216+
handlers :: Handlers (LspM ())
217+
handlers =
218+
requestHandler SMethod_TextDocumentCodeLens $ \req resp -> void $ forkIO $ do
219+
withProgress "Doing something" (req ^. L.params . L.workDoneToken) NotCancellable $ \updater -> do
220+
updater $ ProgressAmount (Just 25) (Just "step1")
221+
updater $ ProgressAmount (Just 50) (Just "step2")
222+
updater $ ProgressAmount (Just 75) (Just "step3")
223+
224+
runSessionWithServer logger definition Test.defaultConfig Test.fullCaps "." $ do
225+
Test.sendRequest SMethod_TextDocumentCodeLens (CodeLensParams (Just $ ProgressToken $ InR "hello") Nothing (TextDocumentIdentifier $ Uri "."))
226+
227+
-- First make sure that we get a $/progress begin notification
228+
skipManyTill Test.anyMessage $ do
229+
x <- Test.message SMethod_Progress
230+
guard $ has (L.params . L.value . _workDoneProgressBegin) x
231+
232+
do
233+
u <- Test.message SMethod_Progress
234+
liftIO $ do
235+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step1")
236+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 25)
237+
238+
do
239+
u <- Test.message SMethod_Progress
240+
liftIO $ do
241+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step2")
242+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 50)
243+
244+
do
245+
u <- Test.message SMethod_Progress
246+
liftIO $ do
247+
u ^? L.params . L.value . _workDoneProgressReport . L.message `shouldBe` Just (Just "step3")
248+
u ^? L.params . L.value . _workDoneProgressReport . L.percentage `shouldBe` Just (Just 75)
249+
250+
-- Then make sure we get a $/progress end notification
251+
skipManyTill Test.anyMessage $ do
252+
x <- Test.message SMethod_Progress
253+
guard $ has (L.params . L.value . _workDoneProgressEnd) x
254+
76255
describe "workspace folders" $
77256
it "keeps track of open workspace folders" $ do
78-
(hinRead, hinWrite) <- createPipe
79-
(houtRead, houtWrite) <- createPipe
80-
81257
countVar <- newMVar 0
82258

83259
let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace"
@@ -116,21 +292,16 @@ main = hspec $ do
116292
_ -> error "Shouldn't be here"
117293
]
118294

119-
server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition
120-
121-
let config =
122-
Test.defaultConfig
123-
{ Test.initialWorkspaceFolders = Just [wf0]
124-
}
295+
let config = Test.defaultConfig{Test.initialWorkspaceFolders = Just [wf0]}
125296

126297
changeFolders add rmv =
127298
let ev = WorkspaceFoldersChangeEvent add rmv
128299
ps = DidChangeWorkspaceFoldersParams ev
129300
in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps
130301

131-
Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do
302+
runSessionWithServer logger definition config Test.fullCaps "." $ do
132303
changeFolders [wf1] []
133304
changeFolders [wf2] [wf1]
134305

135-
Left e <- waitCatch server
136-
fromException e `shouldBe` Just ExitSuccess
306+
main :: IO ()
307+
main = hspec spec

‎lsp-test/lsp-test.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -122,7 +122,9 @@ test-suite func-test
122122
main-is: FuncTest.hs
123123
build-depends:
124124
, base
125+
, aeson
125126
, co-log-core
127+
, containers
126128
, hspec
127129
, lens
128130
, lsp

‎lsp-test/src/Language/LSP/Test/Session.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -330,10 +330,10 @@ updateStateC = awaitForever $ \msg -> do
330330
let (errs, configs) = partitionEithers configsOrErrs
331331

332332
-- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error
333-
if null errs
334-
then sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right configs)
335-
else sendMessage @_ @(TResponseError Method_WorkspaceConfiguration) $
336-
TResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing
333+
sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) $
334+
if null errs
335+
then (Right configs)
336+
else Left $ ResponseError (InL LSPErrorCodes_RequestFailed) ("No configuration for requested sections: " <> (T.pack $ show errs)) Nothing
337337
_ -> pure ()
338338
unless ((ignoringLogNotifications state && isLogNotification msg) || (ignoringConfigurationRequests state && isConfigRequest msg)) $
339339
yield msg

‎lsp/ChangeLog.md

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,14 @@
11
# Revision history for lsp
22

3+
## Unreleased
4+
5+
- Server-created progress now will not send reports until and unless the client
6+
confirms the progress token creation.
7+
- Progress helper functions now can take a progress token provided by the client,
8+
so client-initiated progress can now be supported properly.
9+
- The server options now allow the user to say whether the server should advertise
10+
support for client-initiated progress or not.
11+
312
## 2.3.0.0
413

514
- Fix inference of server capabilities for newer methods (except notebook methods).

‎lsp/example/Reactor.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -314,7 +314,7 @@ handle logger =
314314

315315
logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug
316316
responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request
317-
void $ withProgress "Executing some long running command" Cancellable $ \update ->
317+
void $ withProgress "Executing some long running command" (req ^. LSP.params . LSP.workDoneToken) Cancellable $ \update ->
318318
forM [(0 :: LSP.UInt) .. 10] $ \i -> do
319319
update (ProgressAmount (Just (i * 10)) (Just "Doing stuff"))
320320
liftIO $ threadDelay (1 * 1000000)

0 commit comments

Comments
 (0)