Skip to content

Commit 542ea26

Browse files
soulomoonsoulomoon
committed
restrict the cwd to the outermost layer
1 parent 25108f4 commit 542ea26

File tree

10 files changed

+80
-97
lines changed

10 files changed

+80
-97
lines changed

‎exe/Wrapper.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -269,7 +269,8 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a }
269269
-- to shut down the LSP.
270270
launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO ()
271271
launchErrorLSP recorder errorMsg = do
272-
let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins [])
272+
cwd <- getCurrentDirectory
273+
let defaultArguments = Main.defaultArguments cwd (cmapWithPrio pretty recorder) (IdePlugins [])
273274

274275
inH <- Main.argsHandleIn defaultArguments
275276

‎ghcide/exe/Main.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -112,11 +112,11 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do
112112

113113
let arguments =
114114
if argsTesting
115-
then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins
116-
else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins
115+
then IDEMain.testing argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins
116+
else IDEMain.defaultArguments argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins
117117

118118
IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
119-
{ IDEMain.argsProjectRoot = Just argsCwd
119+
{ IDEMain.argsProjectRoot = argsCwd
120120
, IDEMain.argCommand = argsCommand
121121
, IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]
122122

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -632,15 +632,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
632632

633633
let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
634634
consultCradle hieYaml cfp = do
635-
lfpLog <- flip makeRelative cfp <$> getCurrentDirectory
635+
let lfpLog = makeRelative dir cfp
636636
logWith recorder Info $ LogCradlePath lfpLog
637637

638638
when (isNothing hieYaml) $
639639
logWith recorder Warning $ LogCradleNotFound lfpLog
640640

641641
cradle <- loadCradle recorder hieYaml dir
642642
-- TODO: Why are we repeating the same command we have on line 646?
643-
lfp <- flip makeRelative cfp <$> getCurrentDirectory
643+
let lfp = makeRelative dir cfp
644644

645645
when optTesting $ mRunLspT lspEnv $
646646
sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -128,7 +128,7 @@ setupLSP ::
128128
Recorder (WithPriority Log)
129129
-> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
130130
-> LSP.Handlers (ServerM config)
131-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
131+
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
132132
-> MVar ()
133133
-> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
134134
LSP.Handlers (ServerM config),
@@ -186,7 +186,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
186186
handleInit
187187
:: Recorder (WithPriority Log)
188188
-> (FilePath -> IO FilePath)
189-
-> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
189+
-> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
190190
-> MVar ()
191191
-> IO ()
192192
-> (SomeLspId -> IO ())
@@ -196,7 +196,7 @@ handleInit
196196
handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
197197
traceWithSpan sp params
198198
let root = LSP.resRootPath env
199-
dir <- maybe getCurrentDirectory return root
199+
dir <- maybe (error "No root directory") pure root
200200
dbLoc <- getHieDbLoc dir
201201
let initConfig = parseConfiguration params
202202
logWith recorder Info $ LogRegisteringIdeConfig initConfig
@@ -240,7 +240,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
240240
logWith recorder Info LogReactorThreadStopped
241241

242242
(WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
243-
ide <- getIdeState env root withHieDb hieChan
243+
ide <- getIdeState env dir withHieDb hieChan
244244
registerIdeConfiguration (shakeExtras ide) initConfig
245245
pure $ Right (env,ide)
246246

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 13 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -208,7 +208,7 @@ commandP plugins =
208208

209209

210210
data Arguments = Arguments
211-
{ argsProjectRoot :: Maybe FilePath
211+
{ argsProjectRoot :: FilePath
212212
, argCommand :: Command
213213
, argsRules :: Rules ()
214214
, argsHlsPlugins :: IdePlugins IdeState
@@ -226,9 +226,9 @@ data Arguments = Arguments
226226
, argsDisableKick :: Bool -- ^ flag to disable kick used for testing
227227
}
228228

229-
defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
230-
defaultArguments recorder plugins = Arguments
231-
{ argsProjectRoot = Nothing
229+
defaultArguments :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
230+
defaultArguments fp recorder plugins = Arguments
231+
{ argsProjectRoot = fp
232232
, argCommand = LSP
233233
, argsRules = mainRule (cmapWithPrio LogRules recorder) def
234234
, argsGhcidePlugin = mempty
@@ -263,11 +263,11 @@ defaultArguments recorder plugins = Arguments
263263
}
264264

265265

266-
testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
267-
testing recorder plugins =
266+
testing :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
267+
testing fp recorder plugins =
268268
let
269269
arguments@Arguments{ argsHlsPlugins, argsIdeOptions } =
270-
defaultArguments recorder plugins
270+
defaultArguments fp recorder plugins
271271
hlsPlugins = pluginDescToIdePlugins $
272272
idePluginsToPluginDesc argsHlsPlugins
273273
++ [Test.blockCommandDescriptor "block-command", Test.plugin]
@@ -316,22 +316,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
316316
logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
317317

318318
ideStateVar <- newEmptyMVar
319-
let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
319+
let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState
320320
getIdeState env rootPath withHieDb hieChan = do
321-
traverse_ IO.setCurrentDirectory rootPath
322321
t <- ioT
323322
logWith recorder Info $ LogLspStartDuration t
324-
325-
dir <- maybe IO.getCurrentDirectory return rootPath
326-
327323
-- We want to set the global DynFlags right now, so that we can use
328324
-- `unsafeGlobalDynFlags` even before the project is configured
329325
_mlibdir <-
330-
setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions
326+
setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions
331327
-- TODO: should probably catch/log/rethrow at top level instead
332328
`catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)
333329

334-
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
330+
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath
335331
config <- LSP.runLspT env LSP.getConfig
336332
let def_options = argsIdeOptions config sessionLoader
337333

@@ -378,7 +374,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
378374
runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
379375
dumpSTMStats
380376
Check argFiles -> do
381-
dir <- maybe IO.getCurrentDirectory return argsProjectRoot
377+
let dir = argsProjectRoot
382378
dbLoc <- getHieDbLoc dir
383379
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
384380
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -426,7 +422,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
426422

427423
unless (null failed) (exitWith $ ExitFailure (length failed))
428424
Db opts cmd -> do
429-
root <- maybe IO.getCurrentDirectory return argsProjectRoot
425+
let root = argsProjectRoot
430426
dbLoc <- getHieDbLoc root
431427
hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
432428
mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def
@@ -436,7 +432,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
436432
Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd)
437433

438434
Custom (IdeCommand c) -> do
439-
root <- maybe IO.getCurrentDirectory return argsProjectRoot
435+
let root = argsProjectRoot
440436
dbLoc <- getHieDbLoc root
441437
runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
442438
sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."

‎ghcide/test/exe/ExceptionTests.hs

Lines changed: 42 additions & 62 deletions
Original file line numberDiff line numberDiff line change
@@ -1,56 +1,53 @@
11

22
module ExceptionTests (tests) where
33

4-
import Control.Exception (ArithException (DivideByZero),
5-
throwIO)
4+
import Config
5+
import Control.Exception (ArithException (DivideByZero),
6+
throwIO)
67
import Control.Lens
7-
import Control.Monad.Error.Class (MonadError (throwError))
8-
import Control.Monad.IO.Class (liftIO)
9-
import qualified Data.Aeson as A
10-
import Data.Text as T
11-
import Development.IDE.Core.Shake (IdeState (..))
12-
import qualified Development.IDE.LSP.Notifications as Notifications
13-
import qualified Development.IDE.Main as IDE
14-
import Development.IDE.Plugin.HLS (toResponseError)
15-
import Development.IDE.Plugin.Test as Test
16-
import Development.IDE.Types.Options
17-
import GHC.Base (coerce)
18-
import Ide.Logger (Recorder, WithPriority,
19-
cmapWithPrio)
8+
import Control.Monad.Error.Class (MonadError (throwError))
9+
import Control.Monad.IO.Class (liftIO)
10+
import qualified Data.Aeson as A
11+
import Data.Default (Default (..))
12+
import Data.Text as T
13+
import Development.IDE.Core.Shake (IdeState (..))
14+
import Development.IDE.Plugin.HLS (toResponseError)
15+
import GHC.Base (coerce)
16+
import Ide.Logger (Recorder, WithPriority)
2017
import Ide.Plugin.Error
21-
import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally))
22-
import Ide.PluginUtils (idePluginsToPluginDesc,
23-
pluginDescToIdePlugins)
18+
import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally))
19+
import Ide.PluginUtils (pluginDescToIdePlugins)
2420
import Ide.Types
25-
import qualified Language.LSP.Protocol.Lens as L
21+
import qualified Language.LSP.Protocol.Lens as L
2622
import Language.LSP.Protocol.Message
27-
import Language.LSP.Protocol.Types hiding
28-
(SemanticTokenAbsolute (..),
29-
SemanticTokenRelative (..),
30-
SemanticTokensEdit (..),
31-
mkRange)
23+
import Language.LSP.Protocol.Types hiding
24+
(SemanticTokenAbsolute (..),
25+
SemanticTokenRelative (..),
26+
SemanticTokensEdit (..),
27+
mkRange)
3228
import Language.LSP.Test
33-
import LogType (Log (..))
34-
import Test.Hls (waitForProgressDone)
29+
import LogType (Log (..))
30+
import Test.Hls (runSessionWithServerInTmpDir,
31+
waitForProgressDone)
3532
import Test.Tasty
3633
import Test.Tasty.HUnit
37-
import TestUtils
3834

39-
tests :: Recorder (WithPriority Log) -> TestTree
40-
tests recorder = do
35+
tests :: TestTree
36+
tests = do
4137
testGroup "Exceptions and PluginError" [
4238
testGroup "Testing that IO Exceptions are caught in..."
4339
[ testCase "PluginHandlers" $ do
4440
let pluginId = "plugin-handler-exception"
45-
plugins = pluginDescToIdePlugins $
41+
plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState
42+
plugins _ = pluginDescToIdePlugins $
4643
[ (defaultPluginDescriptor pluginId "")
4744
{ pluginHandlers = mconcat
4845
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
4946
_ <- liftIO $ throwIO DivideByZero
5047
pure (InL [])
5148
]
5249
}]
53-
testIde recorder (testingLite recorder plugins) $ do
50+
runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do
5451
doc <- createDoc "A.hs" "haskell" "module A where"
5552
waitForProgressDone
5653
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
@@ -63,15 +60,16 @@ tests recorder = do
6360
, testCase "Commands" $ do
6461
let pluginId = "command-exception"
6562
commandId = CommandId "exception"
66-
plugins = pluginDescToIdePlugins $
63+
plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState
64+
plugins _ = pluginDescToIdePlugins $
6765
[ (defaultPluginDescriptor pluginId "")
6866
{ pluginCommands =
6967
[ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do
7068
_ <- liftIO $ throwIO DivideByZero
7169
pure (InR Null)
7270
]
7371
}]
74-
testIde recorder (testingLite recorder plugins) $ do
72+
runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do
7573
_ <- createDoc "A.hs" "haskell" "module A where"
7674
waitForProgressDone
7775
let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)])
@@ -85,7 +83,8 @@ tests recorder = do
8583

8684
, testCase "Notification Handlers" $ do
8785
let pluginId = "notification-exception"
88-
plugins = pluginDescToIdePlugins $
86+
plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState
87+
plugins _ = pluginDescToIdePlugins $
8988
[ (defaultPluginDescriptor pluginId "")
9089
{ pluginNotificationHandlers = mconcat
9190
[ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->
@@ -96,7 +95,7 @@ tests recorder = do
9695
pure (InL [])
9796
]
9897
}]
99-
testIde recorder (testingLite recorder plugins) $ do
98+
runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do
10099
doc <- createDoc "A.hs" "haskell" "module A where"
101100
waitForProgressDone
102101
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
@@ -108,37 +107,18 @@ tests recorder = do
108107
_ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]
109108

110109
, testGroup "Testing PluginError order..."
111-
[ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test")
112-
, pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")
113-
, pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)
110+
[ pluginOrderTestCase "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test")
111+
, pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")
112+
, pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)
114113
]
115114
]
116115

117-
testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments
118-
testingLite recorder plugins =
119-
let
120-
arguments@IDE.Arguments{ argsIdeOptions } =
121-
IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins
122-
hlsPlugins = pluginDescToIdePlugins $
123-
idePluginsToPluginDesc plugins
124-
++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]
125-
++ [Test.blockCommandDescriptor "block-command", Test.plugin]
126-
ideOptions config sessionLoader =
127-
let
128-
defOptions = argsIdeOptions config sessionLoader
129-
in
130-
defOptions{ optTesting = IdeTesting True }
131-
in
132-
arguments
133-
{ IDE.argsHlsPlugins = hlsPlugins
134-
, IDE.argsIdeOptions = ideOptions
135-
}
136-
137-
pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree
138-
pluginOrderTestCase recorder msg err1 err2 =
116+
pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree
117+
pluginOrderTestCase msg err1 err2 =
139118
testCase msg $ do
140119
let pluginId = "error-order-test"
141-
plugins = pluginDescToIdePlugins $
120+
plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState
121+
plugins _ = pluginDescToIdePlugins $
142122
[ (defaultPluginDescriptor pluginId "")
143123
{ pluginHandlers = mconcat
144124
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
@@ -147,7 +127,7 @@ pluginOrderTestCase recorder msg err1 err2 =
147127
throwError err2
148128
]
149129
}]
150-
testIde recorder (testingLite recorder plugins) $ do
130+
runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do
151131
doc <- createDoc "A.hs" "haskell" "module A where"
152132
waitForProgressDone
153133
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)

‎ghcide/test/exe/Main.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -114,5 +114,5 @@ main = do
114114
, ReferenceTests.tests
115115
, GarbageCollectionTests.tests
116116
, HieDbRetry.tests
117-
, ExceptionTests.tests recorder
117+
, ExceptionTests.tests
118118
]

0 commit comments

Comments
 (0)