diff --git a/sdk/bazel-haskell-deps.bzl b/sdk/bazel-haskell-deps.bzl index 9451b4bfadae..1c16f16d595b 100644 --- a/sdk/bazel-haskell-deps.bzl +++ b/sdk/bazel-haskell-deps.bzl @@ -551,6 +551,7 @@ exports_files(["stack.exe"], visibility = ["//visibility:public"]) "semigroupoids", "semver", "silently", + "some", "sorted-list", "split", "stache", diff --git a/sdk/compiler/daml-extension/package.json b/sdk/compiler/daml-extension/package.json index 4246e65c9ab2..001035c78f01 100644 --- a/sdk/compiler/daml-extension/package.json +++ b/sdk/compiler/daml-extension/package.json @@ -15,7 +15,8 @@ "onLanguage:daml", "onCommand:daml.openDamlDocs", "onCommand:daml.resetTelemetryConsent", - "onCommand:daml.showResource" + "onCommand:daml.showResource", + "workspaceContains:daml.yaml" ], "main": "./out/src/extension", "contributes": { @@ -78,15 +79,16 @@ "type": "object", "title": "Daml Studio configuration", "properties": { - "daml.debug": { - "type": "boolean", - "default": false, - "description": "Enable debug logging in the Daml Language Server." - }, - "daml.experimental": { - "type": "boolean", - "default": false, - "description": "Enable experimental features in the IDE, this may break things" + "daml.logLevel": { + "enum": [ + "Telemetry", + "Debug", + "Info", + "Warning", + "Error" + ], + "default": "Warning", + "description": "Sets the logging threshold of the daml-ide and multi-ide" }, "daml.profile": { "type": "boolean", @@ -115,12 +117,7 @@ "daml.multiPackageIdeSupport": { "type": "boolean", "default": false, - "description": "VERY EXPERIMENTAL: Enables the incomplete and experimental multi-ide feature." - }, - "daml.multiPackageIdeVerbose": { - "type": "boolean", - "default": false, - "description": "VERY EXPERIMENTAL: Enables verbose logging from the experimental multi-ide feature." + "description": "EXPERIMENTAL: Enables the incomplete and experimental multi-ide feature." } } }, diff --git a/sdk/compiler/daml-extension/src/extension.ts b/sdk/compiler/daml-extension/src/extension.ts index 0248a0b0af1c..30f3eefeb6e4 100644 --- a/sdk/compiler/daml-extension/src/extension.ts +++ b/sdk/compiler/daml-extension/src/extension.ts @@ -13,6 +13,7 @@ import { LanguageClientOptions, RequestType, NotificationType, + Executable, ExecuteCommandRequest, } from "vscode-languageclient/node"; import { @@ -39,85 +40,102 @@ type WebviewFiles = { }; var damlLanguageClient: LanguageClient; +var virtualResourceManager: VirtualResourceManager; +var isMultiIde: boolean; + // Extension activation // Note: You can log debug information by using `console.log()` // and then `Toggle Developer Tools` in VSCode. This will show // output in the Console tab once the extension is activated. export async function activate(context: vscode.ExtensionContext) { - // Start the language clients - let config = vscode.workspace.getConfiguration("daml"); - // Get telemetry consent - const consent = getTelemetryConsent(config, context); + // Add entry for multi-ide readonly directory + let filesConfig = vscode.workspace.getConfiguration("files"); + let multiIdeReadOnlyPattern = "**/.daml/unpacked-dars/**"; + // Explicit any type as typescript gets angry, its a map from pattern (string) to boolean + let readOnlyInclude: any = + filesConfig.inspect("readonlyInclude")?.workspaceValue || {}; + if (!readOnlyInclude[multiIdeReadOnlyPattern]) + filesConfig.update( + "readonlyInclude", + { ...readOnlyInclude, [multiIdeReadOnlyPattern]: true }, + vscode.ConfigurationTarget.Workspace, + ); // Display release notes on updates showReleaseNotesIfNewVersion(context); - damlLanguageClient = createLanguageClient(config, await consent); - damlLanguageClient.registerProposedFeatures(); - const webviewFiles: WebviewFiles = { src: vscode.Uri.file(path.join(context.extensionPath, "src", "webview.js")), css: vscode.Uri.file( path.join(context.extensionPath, "src", "webview.css"), ), }; - let virtualResourceManager = new VirtualResourceManager( - damlLanguageClient, - webviewFiles, - context, - ); - context.subscriptions.push(virtualResourceManager); - let _unused = damlLanguageClient.onReady().then(() => { - startKeepAliveWatchdog(); - damlLanguageClient.onNotification( - DamlVirtualResourceDidChangeNotification.type, - params => virtualResourceManager.setContent(params.uri, params.contents), - ); - damlLanguageClient.onNotification( - DamlVirtualResourceNoteNotification.type, - params => virtualResourceManager.setNote(params.uri, params.note), - ); - damlLanguageClient.onNotification( - DamlVirtualResourceDidProgressNotification.type, - params => - virtualResourceManager.setProgress( - params.uri, - params.millisecondsPassed, - params.startedAt, - ), - ); - vscode.workspace.onDidChangeConfiguration( - (event: vscode.ConfigurationChangeEvent) => { - if (event.affectsConfiguration("daml.multiPackageIdeSupport")) { - const enabled = vscode.workspace - .getConfiguration("daml") - .get("multiPackageIdeSupport"); - let msg = "VSCode must be reloaded for this change to take effect."; - if (enabled) - msg = - msg + - "\nWARNING - The Multi-IDE support is experimental, has bugs, and will likely change without warning. Use at your own risk."; - window - .showInformationMessage(msg, { modal: true }, "Reload now") - .then((option: string | undefined) => { - if (option == "Reload now") - vscode.commands.executeCommand("workbench.action.reloadWindow"); - }); - } else if (event.affectsConfiguration("daml.multiPackageIdeVerbose")) { - let msg = "VSCode must be reloaded for this change to take effect."; - window - .showInformationMessage(msg, { modal: true }, "Reload now") - .then((option: string | undefined) => { - if (option == "Reload now") - vscode.commands.executeCommand("workbench.action.reloadWindow"); - }); - } - }, + async function shutdownLanguageServer() { + // Stop the Language server + stopKeepAliveWatchdog(); + await damlLanguageClient.stop(); + virtualResourceManager.dispose(); + const index = context.subscriptions.indexOf(virtualResourceManager, 0); + if (index > -1) { + context.subscriptions.splice(index, 1); + } + } + + async function setupLanguageServer( + config: vscode.WorkspaceConfiguration, + consent: boolean | undefined, + ) { + damlLanguageClient = createLanguageClient(config, consent); + damlLanguageClient.registerProposedFeatures(); + + virtualResourceManager = new VirtualResourceManager( + damlLanguageClient, + webviewFiles, + context, ); - }); + context.subscriptions.push(virtualResourceManager); + + let _unused = damlLanguageClient.onReady().then(() => { + startKeepAliveWatchdog(); + damlLanguageClient.onNotification( + DamlVirtualResourceDidChangeNotification.type, + params => + virtualResourceManager.setContent(params.uri, params.contents), + ); + damlLanguageClient.onNotification( + DamlVirtualResourceNoteNotification.type, + params => virtualResourceManager.setNote(params.uri, params.note), + ); + damlLanguageClient.onNotification( + DamlVirtualResourceDidProgressNotification.type, + params => + virtualResourceManager.setProgress( + params.uri, + params.millisecondsPassed, + params.startedAt, + ), + ); + }); - damlLanguageClient.start(); + damlLanguageClient.start(); + } + + vscode.workspace.onDidChangeConfiguration( + async (event: vscode.ConfigurationChangeEvent) => { + if (event.affectsConfiguration("daml")) { + await shutdownLanguageServer(); + await new Promise(resolve => setTimeout(resolve, 1000)); + const config = vscode.workspace.getConfiguration("daml"); + const consent = await getTelemetryConsent(config, context); + setupLanguageServer(config, consent); + } + }, + ); + + const config = vscode.workspace.getConfiguration("daml"); + const consent = await getTelemetryConsent(config, context); + setupLanguageServer(config, consent); let d1 = vscode.commands.registerCommand("daml.showResource", (title, uri) => virtualResourceManager.createOrShow(title, uri), @@ -260,6 +278,42 @@ function addIfInConfig( return [].concat.apply([], addedArgs); } +function getLanguageServerArgs( + config: vscode.WorkspaceConfiguration, + telemetryConsent: boolean | undefined, +): string[] { + const multiIDESupport = config.get("multiPackageIdeSupport"); + isMultiIde = !!multiIDESupport; + const logLevel = config.get("logLevel"); + const isDebug = logLevel == "Debug" || logLevel == "Telemetry"; + + let args: string[] = [multiIDESupport ? "multi-ide" : "ide", "--"]; + + if (telemetryConsent === true) { + args.push("--telemetry"); + } else if (telemetryConsent === false) { + args.push("--optOutTelemetry"); + } else if (telemetryConsent == undefined) { + // The user has not made an explicit choice. + args.push("--telemetry-ignored"); + } + if (multiIDESupport === true) { + args.push("--log-level=" + logLevel); + } else { + if (isDebug) args.push("--debug"); + } + const extraArgsString = config.get("extraArguments", "").trim(); + // split on an empty string returns an array with a single empty string + const extraArgs = extraArgsString === "" ? [] : extraArgsString.split(" "); + args = args.concat(extraArgs); + const serverArgs: string[] = addIfInConfig(config, args, [ + ["profile", ["+RTS", "-h", "-RTS"]], + ["autorunAllTests", ["--studio-auto-run-all-scenarios=yes"]], + ]); + + return serverArgs; +} + export function createLanguageClient( config: vscode.WorkspaceConfiguration, telemetryConsent: boolean | undefined, @@ -270,11 +324,7 @@ export function createLanguageClient( documentSelector: ["daml"], }; - const multiIDESupport = config.get("multiPackageIdeSupport"); - const multiIDEVerbose = config.get("multiPackageIdeVerbose"); - let command: string; - let args: string[] = [multiIDESupport ? "multi-ide" : "ide", "--"]; try { command = which.sync("daml"); @@ -290,35 +340,9 @@ export function createLanguageClient( } } - if (telemetryConsent === true) { - args.push("--telemetry"); - } else if (telemetryConsent === false) { - args.push("--optOutTelemetry"); - } else if (telemetryConsent == undefined) { - // The user has not made an explicit choice. - args.push("--telemetry-ignored"); - } - if (multiIDEVerbose === true) { - args.push("--verbose=yes"); - } - const extraArgsString = config.get("extraArguments", "").trim(); - // split on an empty string returns an array with a single empty string - const extraArgs = extraArgsString === "" ? [] : extraArgsString.split(" "); - args = args.concat(extraArgs); - const serverArgs: string[] = addIfInConfig(config, args, [ - ["debug", ["--debug"]], - ["experimental", ["--experimental"]], - ["profile", ["+RTS", "-h", "-RTS"]], - ["autorunAllTests", ["--studio-auto-run-all-scenarios=yes"]], - ]); - - if (config.get("experimental")) { - vscode.window.showWarningMessage( - "Daml's Experimental feature flag is enabled, this may cause instability", - ); - } + const serverArgs = getLanguageServerArgs(config, telemetryConsent); - return new LanguageClient( + const languageClient = new LanguageClient( "daml-language-server", "Daml Language Server", { @@ -329,14 +353,16 @@ export function createLanguageClient( clientOptions, true, ); + return languageClient; } // this method is called when your extension is deactivated -export function deactivate() { +export async function deactivate() { // unLinkSyntax(); // Stop keep-alive watchdog and terminate language server. stopKeepAliveWatchdog(); - (damlLanguageClient)._childProcess.kill("SIGTERM"); + if (isMultiIde) await damlLanguageClient.stop(); + else (damlLanguageClient)._serverProcess.kill("SIGTERM"); } // Keep alive timer for periodically checking that the server is responding diff --git a/sdk/compiler/damlc/BUILD.bazel b/sdk/compiler/damlc/BUILD.bazel index c1e1f04f4ea9..d2719f72b8d8 100644 --- a/sdk/compiler/damlc/BUILD.bazel +++ b/sdk/compiler/damlc/BUILD.bazel @@ -207,6 +207,7 @@ da_haskell_library( "safe", "safe-exceptions", "shake", + "some", "split", "stm", "tasty", @@ -214,6 +215,7 @@ da_haskell_library( "tasty-hunit", "temporary", "text", + "time", "transformers", "uniplate", "unordered-containers", diff --git a/sdk/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs b/sdk/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs index f826acb58f07..9c0f31de1ed6 100644 --- a/sdk/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs +++ b/sdk/compiler/damlc/daml-package-config/src/DA/Daml/Package/Config.hs @@ -103,6 +103,7 @@ checkPkgConfig PackageConfigFields {pName, pVersion} = data MultiPackageConfigFields = MultiPackageConfigFields { mpPackagePaths :: [FilePath] + , mpDars :: [FilePath] } -- | Intermediate of MultiPackageConfigFields that carries links to other config files, before being flattened into a single MultiPackageConfigFields @@ -114,7 +115,9 @@ data MultiPackageConfigFieldsIntermediate = MultiPackageConfigFieldsIntermediate -- | Parse the multi-package.yaml file for auto rebuilds/IDE intelligence in multi-package projects parseMultiPackageConfig :: MultiPackageConfig -> Either ConfigError MultiPackageConfigFieldsIntermediate parseMultiPackageConfig multiPackage = do - mpiConfigFields <- MultiPackageConfigFields . fromMaybe [] <$> queryMultiPackageConfig ["packages"] multiPackage + mpPackagePaths <- fromMaybe [] <$> queryMultiPackageConfig ["packages"] multiPackage + mpDars <- fromMaybe [] <$> queryMultiPackageConfig ["dars"] multiPackage + let mpiConfigFields = MultiPackageConfigFields {..} mpiOtherConfigFiles <- fromMaybe [] <$> queryMultiPackageConfig ["projects"] multiPackage Right MultiPackageConfigFieldsIntermediate {..} @@ -195,10 +198,10 @@ findMultiPackageConfig projectPath = do in pure $ if path == newPath then Right Nothing else Left newPath canonicalizeMultiPackageConfigIntermediate :: ProjectPath -> MultiPackageConfigFieldsIntermediate -> IO MultiPackageConfigFieldsIntermediate -canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFieldsIntermediate (MultiPackageConfigFields packagePaths) multiPackagePaths) = +canonicalizeMultiPackageConfigIntermediate projectPath (MultiPackageConfigFieldsIntermediate (MultiPackageConfigFields packagePaths darPaths) multiPackagePaths) = withCurrentDirectory (unwrapProjectPath projectPath) $ do MultiPackageConfigFieldsIntermediate - <$> (MultiPackageConfigFields <$> traverse canonicalizePath packagePaths) + <$> (MultiPackageConfigFields <$> traverse canonicalizePath packagePaths <*> traverse canonicalizePath darPaths) <*> traverse canonicalizePath multiPackagePaths -- Given some computation to give a result and dependencies, we explore the entire cyclic graph to give the combined @@ -225,7 +228,7 @@ fullParseMultiPackageConfig startPath = do canonMultiPackageConfigI <- canonicalizeMultiPackageConfigIntermediate projectPath multiPackageConfigI pure (ProjectPath <$> mpiOtherConfigFiles canonMultiPackageConfigI, mpiConfigFields canonMultiPackageConfigI) - pure $ MultiPackageConfigFields $ nubOrd $ concatMap mpPackagePaths mpcs + pure $ MultiPackageConfigFields (nubOrd $ concatMap mpPackagePaths mpcs) (nubOrd $ concatMap mpDars mpcs) -- Gives the filepath where the multipackage was found if its not the same as project path. withMultiPackageConfig :: ProjectPath -> (MultiPackageConfigFields -> IO a) -> IO a diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs index a50837f7f33f..2cdd16ea8dc8 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -34,6 +34,7 @@ import DA.Cli.Options (Debug(..), Style(..), Telemetry(..), cliOptDetailLevel, + cliOptLogLevel, debugOpt, disabledDlintUsageParser, enabledDlintUsageParser, @@ -45,7 +46,6 @@ import DA.Cli.Options (Debug(..), inputDarOpt, inputFileOpt, inputFileOptWithExt, - multiIdeVerboseOpt, multiPackageBuildAllOpt, multiPackageCleanAllOpt, multiPackageLocationOpt, @@ -228,6 +228,7 @@ import Options.Applicative ((<|>), execParserPure, flag, flag', + forwardOptions, fullDesc, handleParseResult, headerDoc, @@ -242,6 +243,7 @@ import Options.Applicative ((<|>), prefs, progDesc, renderFailure, + strArgument, subparser, switch, value) @@ -307,15 +309,17 @@ data CommandName = deriving (Ord, Show, Eq) data Command = Command CommandName (Maybe ProjectOpts) (IO ()) -cmdMultiIde :: Int -> Mod CommandFields Command +cmdMultiIde :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command cmdMultiIde _numProcessors = command "multi-ide" $ info (helper <*> cmd) $ progDesc "Start the Daml Multi-IDE language server on standard input/output." <> fullDesc + <> forwardOptions where cmd = fmap (Command MultiIde Nothing) $ runMultiIde - <$> multiIdeVerboseOpt + <$> cliOptLogLevel + <*> many (strArgument mempty) cmdIde :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command cmdIde numProcessors = diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs index 2c8444070c9b..773d84b99800 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs @@ -1,57 +1,79 @@ -- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} module DA.Cli.Damlc.Command.MultiIde (runMultiIde) where +import qualified "zip-archive" Codec.Archive.Zip as Zip +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async, cancel, pollSTM) import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TVar import Control.Concurrent.MVar -import Control.Exception(AsyncException, handle, throwIO) +import Control.Exception(SomeException, displayException, fromException, try) import Control.Lens import Control.Monad import Control.Monad.STM +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (StateT, runStateT, gets, modify') import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC import DA.Cli.Damlc.Command.MultiIde.Forwarding import DA.Cli.Damlc.Command.MultiIde.Prefixing import DA.Cli.Damlc.Command.MultiIde.Util import DA.Cli.Damlc.Command.MultiIde.Parsing import DA.Cli.Damlc.Command.MultiIde.Types -import DA.Cli.Options (MultiIdeVerbose (..)) +import DA.Cli.Damlc.Command.MultiIde.DarDependencies (resolveSourceLocation, unpackDar, unpackedDarsLocation) import DA.Daml.LanguageServer.SplitGotoDefinition +import DA.Daml.LF.Reader (DalfManifest(..), readDalfManifest) import DA.Daml.Package.Config (MultiPackageConfigFields(..), findMultiPackageConfig, withMultiPackageConfig) +import DA.Daml.Project.Consts (projectConfigName) import DA.Daml.Project.Types (ProjectPath (..)) +import qualified DA.Service.Logger as Logger import Data.Either (lefts) +import Data.Either.Extra (eitherToMaybe) import Data.Foldable (traverse_) -import Data.Functor.Product -import Data.List (find, isPrefixOf) +import Data.List (find, isInfixOf) import qualified Data.Map as Map -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, maybeToList) +import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Extended as TE +import qualified Data.Text.IO as T +import Data.Time.Clock (getCurrentTime) import GHC.Conc (unsafeIOToSTM) import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as LSP -import System.Environment (getEnv) +import qualified SdkVersion.Class +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getEnv, getEnvironment) +import System.Exit (exitSuccess) +import System.FilePath.Posix (takeDirectory, takeExtension, takeFileName, ()) import System.IO.Extra -import System.Process (getPid) +import System.Info.Extra (isWindows) +import System.Process (getPid, terminateProcess) import System.Process.Typed ( + ExitCode (..), Process, - createPipe, + StreamSpec, getExitCodeSTM, + getStderr, getStdin, getStdout, - nullStream, + mkPipeStreamSpec, proc, + setEnv, setStderr, setStdin, setStdout, @@ -65,222 +87,379 @@ import System.Process.Typed ( -- add IDE, send initialize, do not send further messages until we get the initialize response and have sent initialized -- we can do this by locking the sending thread, but still allowing the channel to be pushed -- we also atomically send a message to the channel, without dropping the lock on the subIDEs var +-- Note that messages sent here should _already_ be in the fromClientMessage tracker addNewSubIDEAndSend :: MultiIdeState - -> FilePath - -> LSP.FromClientMessage - -> IO SubIDE -addNewSubIDEAndSend miState home msg = do - debugPrint miState "Trying to make a SubIDE" - ides <- atomically $ takeTMVar $ subIDEsVar miState - - let mExistingIde = Map.lookup home $ onlyActiveSubIdes ides - case mExistingIde of + -> PackageHome + -> Maybe LSP.FromClientMessage + -> IO () +addNewSubIDEAndSend miState home mMsg = + withIDEs_ miState $ \ides -> unsafeAddNewSubIDEAndSend miState ides home mMsg + +-- Unsafe as does not acquire SubIDEsVar, instead simply transforms it +unsafeAddNewSubIDEAndSend + :: MultiIdeState + -> SubIDEs + -> PackageHome + -> Maybe LSP.FromClientMessage + -> IO SubIDEs +unsafeAddNewSubIDEAndSend miState ides home mMsg = do + logDebug miState "Trying to make a SubIDE" + + let ideData = lookupSubIde home ides + case ideDataMain ideData of Just ide -> do - debugPrint miState "SubIDE already exists" - unsafeSendSubIDE ide msg - atomically $ putTMVar (subIDEsVar miState) ides - pure ide + logDebug miState "SubIDE already exists" + forM_ mMsg $ unsafeSendSubIDE ide + pure ides + Nothing | ideShouldDisable ideData || ideDataDisabled ideData -> do + when (ideShouldDisable ideData) $ logDebug miState $ "SubIDE failed twice within " <> show ideShouldDisableTimeout <> ", disabling SubIDE" + + responses <- getUnrespondedRequestsFallbackResponses miState ideData home + logDebug miState $ "Found " <> show (length responses) <> " unresponded messages, sending empty replies." + + -- Doesn't include mMsg, as if it was request, it'll already be in the tracker, so a reply for it will be in `responses` + -- As such, we cannot send this on every failed message, + let ideData' = ideData {ideDataDisabled = True, ideDataFailTimes = []} + -- Only add diagnostic messages for first fail to start. + -- Diagnostic messages trigger the client to send a codeAction request, which would create an infinite loop if we sent + -- diagnostics with its reply + messages = responses <> if ideShouldDisable ideData then disableIdeDiagnosticMessages ideData else [] + + atomically $ traverse_ (sendClientSTM miState) messages + pure $ Map.insert home ideData' ides Nothing -> do - debugPrint miState "Making a SubIDE" + logInfo miState $ "Creating new SubIDE for " <> unPackageHome home + traverse_ (sendClient miState) $ clearIdeDiagnosticMessages ideData - unitId <- either (\cErr -> error $ "Failed to get unit ID from daml.yaml: " <> show cErr) id <$> unitIdFromDamlYaml home + unitId <- either (\cErr -> error $ "Failed to get unit ID from daml.yaml: " <> show cErr) fst <$> unitIdAndDepsFromDamlYaml home - subIdeProcess <- runSubProc home + subIdeProcess <- runSubProc miState home let inHandle = getStdin subIdeProcess outHandle = getStdout subIdeProcess + errHandle = getStderr subIdeProcess + + ideErrText <- newTVarIO @T.Text "" -- Handles blocking the sender thread until the IDE is initialized. - sendBlocker <- newEmptyMVar @() - let unblock = putMVar sendBlocker () - onceUnblocked = (readMVar sendBlocker >>) + (onceUnblocked, unblock) <- makeIOBlocker -- ***** -> SubIDE toSubIDEChan <- atomically newTChan - toSubIDE <- async $ onceUnblocked $ forever $ do - msg <- atomically $ readTChan toSubIDEChan - debugPrint miState "Pushing message to subIDE" - putChunk inHandle msg + let pushMessageToSubIDE :: IO () + pushMessageToSubIDE = do + msg <- atomically $ readTChan toSubIDEChan + logDebug miState "Pushing message to subIDE" + putChunk inHandle msg + toSubIDE <- async $ do + -- Allow first message (init) to be sent before unblocked + pushMessageToSubIDE + onceUnblocked $ forever pushMessageToSubIDE -- Coord <- SubIDE subIDEToCoord <- async $ do -- Wait until our own IDE exists then pass it forward - ide <- atomically $ fromMaybe (error "Failed to get own IDE") . Map.lookup home . onlyActiveSubIdes <$> readTMVar (subIDEsVar miState) + ide <- atomically $ fromMaybe (error "Failed to get own IDE") . ideDataMain . lookupSubIde home <$> readTMVar (subIDEsVar miState) onChunks outHandle $ subIDEMessageHandler miState unblock ide pid <- fromMaybe (error "SubIDE has no PID") <$> getPid (unsafeProcessHandle subIdeProcess) + ideErrTextAsync <- async $ + let go = do + text <- T.hGetChunk errHandle + unless (text == "") $ do + atomically $ modifyTVar' ideErrText (<> text) + logDebug miState $ "[SubIDE " <> show pid <> "] " <> T.unpack text + go + in go + mInitParams <- tryReadMVar (initParamsVar miState) - let !initParams = fromMaybe (error "Attempted to create a SubIDE before initialization!") mInitParams - initId = LSP.IdString $ T.pack $ show pid - (initMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SInitialize LSP.RequestMessage - { _id = initId - , _method = LSP.SInitialize - , _params = initParams - { LSP._rootPath = Just $ T.pack home - , LSP._rootUri = Just $ LSP.filePathToUri home - } - , _jsonrpc = "2.0" - } - ide = - SubIDE + let ide = + SubIDEInstance { ideInhandleAsync = toSubIDE , ideInHandle = inHandle , ideInHandleChannel = toSubIDEChan + , ideOutHandle = outHandle , ideOutHandleAsync = subIDEToCoord + , ideErrHandle = errHandle + , ideErrText = ideErrText + , ideErrTextAsync = ideErrTextAsync , ideProcess = subIdeProcess - , ideHomeDirectory = home + , ideHome = home , ideMessageIdPrefix = T.pack $ show pid - , ideActive = True , ideUnitId = unitId } + ideData' = ideData {ideDataMain = Just ide} + !initParams = fromMaybe (error "Attempted to create a SubIDE before initialization!") mInitParams + initMsg = initializeRequest initParams ide + + -- Must happen before the initialize message is added, else it'll delete that + unrespondedRequests <- getUnrespondedRequestsToResend miState ideData home + + logDebug miState "Sending init message to SubIDE" + putSingleFromClientMessage miState home initMsg + unsafeSendSubIDE ide initMsg + + -- Dangerous calls are okay here because we're already holding the subIDEsVar lock + -- Send the open file notifications + logDebug miState "Sending open files messages to SubIDE" + forM_ (ideDataOpenFiles ideData') $ \path -> do + content <- TE.readFileUtf8 $ unDamlFile path + unsafeSendSubIDE ide $ openFileNotification path content + + + -- Resend all pending requests + -- No need for re-prefixing or anything like that, messages are stored with the prefixes they need + -- Note that we want to remove the message we're sending from this list, to not send it twice + let mMsgLspId = mMsg >>= fromClientRequestLspId + requestsToResend = filter (\req -> fromClientRequestLspId req /= mMsgLspId) unrespondedRequests + logDebug miState $ "Found " <> show (length requestsToResend) <> " unresponded messages, resending:\n" + <> show (fmap (\r -> (fromClientRequestMethod r, fromClientRequestLspId r)) requestsToResend) + traverse_ (unsafeSendSubIDE ide) requestsToResend - putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) initId LSP.SInitialize - putChunk inHandle $ Aeson.encode initMsg - -- Dangerous call is okay here because we're already holding the subIDEsVar lock - unsafeSendSubIDE ide msg + logDebug miState $ "Sending intended message to SubIDE: " <> show ((\r -> (fromClientRequestMethod r, fromClientRequestLspId r)) <$> mMsg) + -- Send the intended message + forM_ mMsg $ unsafeSendSubIDE ide - atomically $ putTMVar (subIDEsVar miState) $ Map.insert home ide ides + pure $ Map.insert home ideData' ides - pure ide +disableIdeDiagnosticMessages :: SubIDEData -> [LSP.FromServerMessage] +disableIdeDiagnosticMessages ideData = + fullFileDiagnostic + ( "Daml IDE environment failed to start with the following error:\n" + <> fromMaybe "No information" (ideDataLastError ideData) + ) + <$> ((unPackageHome (ideDataHome ideData) "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData)) -runSubProc :: FilePath -> IO (Process Handle Handle ()) -runSubProc home = do +clearIdeDiagnosticMessages :: SubIDEData -> [LSP.FromServerMessage] +clearIdeDiagnosticMessages ideData = + clearDiagnostics <$> ((unPackageHome (ideDataHome ideData) "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData)) + +runSubProc :: MultiIdeState -> PackageHome -> IO (Process Handle Handle Handle) +runSubProc miState home = do assistantPath <- getEnv "DAML_ASSISTANT" + -- Need to remove some variables so the sub-assistant will pick them up from the working dir/daml.yaml + assistantEnv <- filter (flip notElem ["DAML_PROJECT", "DAML_SDK_VERSION", "DAML_SDK"] . fst) <$> getEnvironment startProcess $ - proc assistantPath ["ide"] & - setStdin createPipe & - setStdout createPipe & - -- setStderr (useHandleOpen stderr) & - setStderr nullStream & - setWorkingDir home + proc assistantPath ("ide" : subIdeArgs miState) & + setStdin createPipeNoClose & + setStdout createPipeNoClose & + setStderr createPipeNoClose & + setWorkingDir (unPackageHome home) & + setEnv assistantEnv + where + createPipeNoClose :: StreamSpec streamType Handle + createPipeNoClose = mkPipeStreamSpec $ \_ h -> pure (h, pure ()) -- Spin-down logic - --- Sends a shutdown message and sets active to false, disallowing any further messages to be sent to the subIDE +rebootIdeByHome :: MultiIdeState -> PackageHome -> IO () +rebootIdeByHome miState home = withIDEs_ miState $ \ides -> do + ides' <- unsafeShutdownIdeByHome miState ides home + unsafeAddNewSubIDEAndSend miState ides' home Nothing + +-- Version of rebootIdeByHome that only spins up IDEs that were either active, or disabled. +-- Does not spin up IDEs that were naturally shutdown/never started +lenientRebootIdeByHome :: MultiIdeState -> PackageHome -> IO () +lenientRebootIdeByHome miState home = withIDEs_ miState $ \ides -> do + let ideData = lookupSubIde home ides + shouldBoot = isJust (ideDataMain ideData) || ideDataDisabled ideData + ides' <- unsafeShutdownIdeByHome miState ides home + if shouldBoot + then unsafeAddNewSubIDEAndSend miState ides' home Nothing + else pure ides' + +-- Checks if a shutdown message LspId originated from the multi-ide coordinator +isCoordinatorShutdownLspId :: LSP.LspId 'LSP.Shutdown -> Bool +isCoordinatorShutdownLspId (LSP.IdString str) = "-shutdown" `T.isSuffixOf` str +isCoordinatorShutdownLspId _ = False + +-- Sends a shutdown message and moves SubIDEInstance to `ideDataClosing`, disallowing any further client messages to be sent to the subIDE -- given queue nature of TChan, all other pending messages will be sent first before handling shutdown -shutdownIde :: MultiIdeState -> SubIDE -> IO () -shutdownIde miState ide = do - ides <- atomically $ takeTMVar (subIDEsVar miState) - let shutdownId = LSP.IdString $ ideMessageIdPrefix ide <> "-shutdown" - (shutdownMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SShutdown LSP.RequestMessage - { _id = shutdownId - , _method = LSP.SShutdown - , _params = LSP.Empty - , _jsonrpc = "2.0" - } - - putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) shutdownId LSP.SShutdown - unsafeSendSubIDE ide shutdownMsg - - atomically $ putTMVar (subIDEsVar miState) $ Map.adjust (\ide' -> ide' {ideActive = False}) (ideHomeDirectory ide) ides +shutdownIdeByHome :: MultiIdeState -> PackageHome -> IO () +shutdownIdeByHome miState home = withIDEs_ miState $ \ides -> unsafeShutdownIdeByHome miState ides home + +-- Unsafe as does not acquire SubIDEsVar, instead simply transforms it +unsafeShutdownIdeByHome :: MultiIdeState -> SubIDEs -> PackageHome -> IO SubIDEs +unsafeShutdownIdeByHome miState ides home = do + let ideData = lookupSubIde home ides + case ideDataMain ideData of + Just ide -> do + let shutdownId = LSP.IdString $ ideMessageIdPrefix ide <> "-shutdown" + shutdownMsg :: LSP.FromClientMessage + shutdownMsg = LSP.FromClientMess LSP.SShutdown LSP.RequestMessage + { _id = shutdownId + , _method = LSP.SShutdown + , _params = LSP.Empty + , _jsonrpc = "2.0" + } + + logDebug miState $ "Sending shutdown message to " <> unPackageHome (ideDataHome ideData) + + putSingleFromClientMessage miState home shutdownMsg + unsafeSendSubIDE ide shutdownMsg + pure $ Map.adjust (\ideData' -> ideData' + { ideDataMain = Nothing + , ideDataClosing = Set.insert ide $ ideDataClosing ideData + , ideDataFailTimes = [] + , ideDataDisabled = False + }) home ides + Nothing -> + pure $ Map.adjust (\ideData -> ideData {ideDataFailTimes = [], ideDataDisabled = False}) home ides -- To be called once we receive the Shutdown response -- Safe to assume that the sending channel is empty, so we can end the thread and send the final notification directly on the handle -handleExit :: MultiIdeState -> SubIDE -> IO () -handleExit miState ide = do - let (exitMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SExit LSP.NotificationMessage - { _method = LSP.SExit - , _params = LSP.Empty - , _jsonrpc = "2.0" - } - -- This will cause the subIDE process to exit - putChunk (ideInHandle ide) $ Aeson.encode exitMsg - atomically $ modifyTMVar (subIDEsVar miState) $ Map.delete (ideHomeDirectory ide) - cancel $ ideInhandleAsync ide - cancel $ ideOutHandleAsync ide +handleExit :: MultiIdeState -> SubIDEInstance -> IO () +handleExit miState ide = + if isWindows + then do + -- On windows, ghc-ide doesn't close correctly on exit messages (even terminating the process leaves subprocesses behind) + -- Instead, we close the handle its listening on, and terminate the process. + logDebug miState $ "(windows) Closing handle and terminating " <> unPackageHome (ideHome ide) + hTryClose $ ideInHandle ide + terminateProcess $ unsafeProcessHandle $ ideProcess ide + else do + let (exitMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SExit LSP.NotificationMessage + { _method = LSP.SExit + , _params = LSP.Empty + , _jsonrpc = "2.0" + } + logDebug miState $ "Sending exit message to " <> unPackageHome (ideHome ide) + -- This will cause the subIDE process to exit + -- Able to be unsafe as no other messages can use this IDE once it has been shutdown + unsafeSendSubIDE ide exitMsg -- Communication logic -- Dangerous as does not hold the subIDEsVar lock. If a shutdown is called whiled this is running, the message may not be sent. -unsafeSendSubIDE :: SubIDE -> LSP.FromClientMessage -> IO () +unsafeSendSubIDE :: SubIDEInstance -> LSP.FromClientMessage -> IO () unsafeSendSubIDE ide = atomically . unsafeSendSubIDESTM ide -unsafeSendSubIDESTM :: SubIDE -> LSP.FromClientMessage -> STM () +unsafeSendSubIDESTM :: SubIDEInstance -> LSP.FromClientMessage -> STM () unsafeSendSubIDESTM ide = writeTChan (ideInHandleChannel ide) . Aeson.encode +sendClientSTM :: MultiIdeState -> LSP.FromServerMessage -> STM () +sendClientSTM miState = writeTChan (toClientChan miState) . Aeson.encode + sendClient :: MultiIdeState -> LSP.FromServerMessage -> IO () -sendClient miState = atomically . writeTChan (toClientChan miState) . Aeson.encode +sendClient miState = atomically . sendClientSTM miState + +-- Sends a message to the client, putting it at the start of the queue to be sent first +sendClientFirst :: MultiIdeState -> LSP.FromServerMessage -> IO () +sendClientFirst miState = atomically . unGetTChan (toClientChan miState) . Aeson.encode -sendAllSubIDEs :: MultiIdeState -> LSP.FromClientMessage -> IO [FilePath] -sendAllSubIDEs miState msg = atomically $ do - idesUnfiltered <- takeTMVar (subIDEsVar miState) - let ides = onlyActiveSubIdes idesUnfiltered - when (null ides) $ error "Got a broadcast to nothing :(" - homes <- forM (Map.elems ides) $ \ide -> ideHomeDirectory ide <$ writeTChan (ideInHandleChannel ide) (Aeson.encode msg) - putTMVar (subIDEsVar miState) idesUnfiltered - pure homes +sendAllSubIDEs :: MultiIdeState -> LSP.FromClientMessage -> IO [PackageHome] +sendAllSubIDEs miState msg = holdingIDEsAtomic miState $ \ides -> + let ideInstances = mapMaybe ideDataMain $ Map.elems ides + in forM ideInstances $ \ide -> ideHome ide <$ unsafeSendSubIDESTM ide msg sendAllSubIDEs_ :: MultiIdeState -> LSP.FromClientMessage -> IO () sendAllSubIDEs_ miState = void . sendAllSubIDEs miState +getSourceFileHome :: MultiIdeState -> FilePath -> STM (Maybe PackageHome) +getSourceFileHome miState path = do + sourceFileHomes <- takeTMVar (sourceFileHomesVar miState) + case Map.lookup path sourceFileHomes of + Just home -> do + putTMVar (sourceFileHomesVar miState) sourceFileHomes + unsafeIOToSTM $ logDebug miState $ "Found cached home for " <> path + pure $ Just home + Nothing -> do + -- Safe as repeat prints are acceptable + unsafeIOToSTM $ logDebug miState $ "No cached home for " <> path + -- Read only operation, so safe within STM + mHome <- unsafeIOToSTM $ findHome path + unsafeIOToSTM $ logDebug miState $ "File system yielded " <> show (unPackageHome <$> mHome) + putTMVar (sourceFileHomesVar miState) $ maybe sourceFileHomes (\home -> Map.insert path home sourceFileHomes) mHome + pure mHome + +sourceFileHomeDeleted :: MultiIdeState -> FilePath -> IO () +sourceFileHomeDeleted miState path = atomically $ modifyTMVar (sourceFileHomesVar miState) $ Map.delete path + +-- When a daml.yaml changes, all files pointing to it are invalidated in the cache +sourceFileHomeDamlYamlChanged :: MultiIdeState -> PackageHome -> IO () +sourceFileHomeDamlYamlChanged miState home = atomically $ modifyTMVar (sourceFileHomesVar miState) $ Map.filter (/=home) + sendSubIDEByPath :: MultiIdeState -> FilePath -> LSP.FromClientMessage -> IO () sendSubIDEByPath miState path msg = do - mHome <- sendSubIDEByPath_ path msg - -- Lock is dropped then regained here for new IDE. This is acceptable as it's impossible for a shutdown - -- of the new ide to be sent before its created. - -- Note that if sendSubIDEByPath is called multiple times concurrently for a new IDE, addNewSubIDEAndSend may be called twice for the same home - -- addNewSubIDEAndSend handles this internally with its own checks, so this is acceptable. - forM_ mHome $ \home -> addNewSubIDEAndSend miState home msg - where - -- If a SubIDE is needed, returns the path out of the STM transaction - sendSubIDEByPath_ :: FilePath -> LSP.FromClientMessage -> IO (Maybe FilePath) - sendSubIDEByPath_ path msg = atomically $ do - idesUnfiltered <- takeTMVar (subIDEsVar miState) - let ides = onlyActiveSubIdes idesUnfiltered - -- Map.keys gives keys in ascending order, so first match will be the shortest. - -- No possibility to accidentally pick a nested package. - mHome = find (`isPrefixOf` path) $ Map.keys ides - mIde = mHome >>= flip Map.lookup ides - - case mIde of - Just ide -> do - writeTChan (ideInHandleChannel ide) (Aeson.encode msg) - unsafeIOToSTM $ debugPrint miState $ "Found relevant SubIDE: " <> ideHomeDirectory ide - putTMVar (subIDEsVar miState) idesUnfiltered - pure Nothing - Nothing -> do - putTMVar (subIDEsVar miState) idesUnfiltered - -- Safe as findHome only does reads - mHome <- unsafeIOToSTM $ findHome path - case mHome of - -- Returned out of the transaction to be handled in IO - Just home -> pure $ Just home - Nothing -> do - -- We get here if we cannot find a daml.yaml file for a file mentioned in a request - -- if we're sending a response, ignore it, as this means the server that sent the request has been killed already. - -- if we're sending a request, respond to the client with an error. - -- if we're sending a notification, ignore it - theres nothing the protocol allows us to do to signify notification failures. - let replyError :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.SMethod m -> LSP.LspId m -> STM () - replyError method id = - writeTChan (toClientChan miState) $ Aeson.encode $ - LSP.FromServerRsp method $ LSP.ResponseMessage "2.0" (Just id) $ Left $ - LSP.ResponseError LSP.InvalidParams ("Could not find daml.yaml for package containing " <> T.pack path) Nothing - case msg of - LSP.FromClientMess method params -> - case (LSP.splitClientMethod method, params) of - (LSP.IsClientReq, LSP.RequestMessage {_id}) -> Nothing <$ replyError method _id - (LSP.IsClientEither, LSP.ReqMess (LSP.RequestMessage {_id})) -> Nothing <$ replyError method _id - _ -> pure Nothing - _ -> pure Nothing + mHome <- atomically $ getSourceFileHome miState path + + case mHome of + Just home -> do + putSingleFromClientMessage miState home msg + + withIDEs_ miState $ \ides -> do + let ideData = lookupSubIde home ides + case ideDataMain ideData of + -- Here we already have a subIDE, so we forward our message to it before dropping the lock + Just ide -> do + unsafeSendSubIDE ide msg + logDebug miState $ "Found relevant SubIDE: " <> unPackageHome (ideDataHome ideData) + pure ides + -- This path will create a new subIDE at the given home + Nothing -> do + unsafeAddNewSubIDEAndSend miState ides home $ Just msg + Nothing -> do + -- We get here if we cannot find a daml.yaml file for a file mentioned in a request + -- if we're sending a response, ignore it, as this means the server that sent the request has been killed already. + -- if we're sending a request, respond to the client with an error. + -- if we're sending a notification, ignore it - theres nothing the protocol allows us to do to signify notification failures. + let replyError :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.SMethod m -> LSP.LspId m -> IO () + replyError method id = + sendClient miState $ LSP.FromServerRsp method $ LSP.ResponseMessage "2.0" (Just id) $ Left + $ LSP.ResponseError LSP.InvalidParams ("Could not find daml.yaml for package containing " <> T.pack path) Nothing + case msg of + LSP.FromClientMess method params -> + case (LSP.splitClientMethod method, params) of + (LSP.IsClientReq, LSP.RequestMessage {_id}) -> replyError method _id + (LSP.IsClientEither, LSP.ReqMess (LSP.RequestMessage {_id})) -> replyError method _id + _ -> pure () + _ -> pure () parseCustomResult :: Aeson.FromJSON a => String -> Either LSP.ResponseError Aeson.Value -> Either LSP.ResponseError a parseCustomResult name = fmap $ either (\err -> error $ "Failed to parse response of " <> name <> ": " <> err) id - . Aeson.parseEither Aeson.parseJSON + . Aeson.parseEither Aeson.parseJSON + +onOpenFiles :: MultiIdeState -> PackageHome -> (Set.Set DamlFile -> Set.Set DamlFile) -> STM () +onOpenFiles miState home f = modifyTMVarM (subIDEsVar miState) $ \subIdes -> do + let ideData = lookupSubIde home subIdes + ideData' = ideData {ideDataOpenFiles = f $ ideDataOpenFiles ideData} + when (ideDataDisabled ideData') $ traverse_ (sendClientSTM miState) $ disableIdeDiagnosticMessages ideData' + pure $ Map.insert home ideData' subIdes + +addOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM () +addOpenFile miState home file = do + unsafeIOToSTM $ logInfo miState $ "Added open file " <> unDamlFile file <> " to " <> unPackageHome home + onOpenFiles miState home $ Set.insert file + +removeOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM () +removeOpenFile miState home file = do + unsafeIOToSTM $ logInfo miState $ "Removed open file " <> unDamlFile file <> " from " <> unPackageHome home + onOpenFiles miState home $ Set.delete file + +resolveAndUnpackSourceLocation :: MultiIdeState -> PackageSourceLocation -> IO PackageHome +resolveAndUnpackSourceLocation miState pkgSource = do + (pkgPath, mDarPath) <- resolveSourceLocation miState pkgSource + forM_ mDarPath $ \darPath -> do + -- Must shutdown existing IDE first, since folder could be deleted + -- If no IDE exists, shutdown is a no-op + logDebug miState $ "Shutting down existing unpacked dar at " <> unPackageHome pkgPath + shutdownIdeByHome miState pkgPath + unpackDar miState darPath + pure pkgPath -- Handlers -subIDEMessageHandler :: MultiIdeState -> IO () -> SubIDE -> B.ByteString -> IO () +subIDEMessageHandler :: MultiIdeState -> IO () -> SubIDEInstance -> B.ByteString -> IO () subIDEMessageHandler miState unblock ide bs = do - debugPrint miState "Called subIDEMessageHandler" + logInfo miState $ "Got new message from " <> unPackageHome (ideHome ide) -- Decode a value, parse let val :: Aeson.Value val = er "eitherDecode" $ Aeson.eitherDecodeStrict bs - mMsg <- either error id <$> parseServerMessageWithTracker (fromClientMethodTrackerVar miState) (ideHomeDirectory ide) val + mMsg <- either error id <$> parseServerMessageWithTracker (fromClientMethodTrackerVar miState) (ideHome ide) val -- Adds the various prefixes needed for from server messages to not clash with those from other IDEs let prefixer :: LSP.FromServerMessage -> LSP.FromServerMessage @@ -292,29 +471,29 @@ subIDEMessageHandler miState unblock ide bs = do forM_ mPrefixedMsg $ \msg -> do -- If its a request (builtin or custom), save it for response handling. - putServerReq (fromServerMethodTrackerVar miState) (ideHomeDirectory ide) msg + putFromServerMessage miState (ideHome ide) msg - debugPrint miState "Message successfully parsed and prefixed." + logDebug miState "Message successfully parsed and prefixed." case msg of LSP.FromServerRsp LSP.SInitialize LSP.ResponseMessage {_result} -> do - debugPrint miState "Got initialization reply, sending initialized and unblocking" + logDebug miState "Got initialization reply, sending initialized and unblocking" -- Dangerous call here is acceptable as this only happens while the ide is booting, before unblocking unsafeSendSubIDE ide $ LSP.FromClientMess LSP.SInitialized $ LSP.NotificationMessage "2.0" LSP.SInitialized (Just LSP.InitializedParams) unblock - LSP.FromServerRsp LSP.SShutdown _ -> handleExit miState ide + LSP.FromServerRsp LSP.SShutdown (LSP.ResponseMessage {_id}) | maybe False isCoordinatorShutdownLspId _id -> handleExit miState ide -- See STextDocumentDefinition in client handle for description of this path LSP.FromServerRsp (LSP.SCustomMethod "daml/tryGetDefinition") LSP.ResponseMessage {_id, _result} -> do - debugPrint miState "Got tryGetDefinition response, handling..." + logInfo miState "Got tryGetDefinition response, handling..." let parsedResult = parseCustomResult @(Maybe TryGetDefinitionResult) "daml/tryGetDefinition" _result reply :: Either LSP.ResponseError (LSP.ResponseResult 'LSP.TextDocumentDefinition) -> IO () reply rsp = do - debugPrint miState $ "Replying directly to client with " <> show rsp + logDebug miState $ "Replying directly to client with " <> show rsp sendClient miState $ LSP.FromServerRsp LSP.STextDocumentDefinition $ LSP.ResponseMessage "2.0" (castLspId <$> _id) rsp replyLocations :: [LSP.Location] -> IO () replyLocations = reply . Right . LSP.InR . LSP.InL . LSP.List case parsedResult of - -- Request failed, forwrd error + -- Request failed, forward error Left err -> reply $ Left err -- Request didn't find any location information, forward "nothing" Right Nothing -> replyLocations [] @@ -324,51 +503,63 @@ subIDEMessageHandler miState unblock ide bs = do -- SubIDE containing the reference did not contain the definition, it returns a fake location in .daml and the name -- Send a new request to a new SubIDE to find the source of this name Right (Just (TryGetDefinitionResult loc (Just name))) -> do - debugPrint miState $ "Got name in result! Backup location is " <> show loc - let mHome = Map.lookup (tgdnPackageUnitId name) $ multiPackageMapping miState - case mHome of + logDebug miState $ "Got name in result! Backup location is " <> show loc + mSourceLocation <- Map.lookup (UnitId $ tgdnPackageUnitId name) <$> atomically (readTMVar $ multiPackageMappingVar miState) + case mSourceLocation of -- Didn't find a home for this name, we do not know where this is defined, so give back the (known to be wrong) -- .daml data-dependency path -- This is the worst case, we'll later add logic here to unpack and spinup an SubIDE for the read-only dependency Nothing -> replyLocations [loc] -- We found a daml.yaml for this definition, send the getDefinitionByName request to its SubIDE - Just home -> do - debugPrint miState $ "Found unit ID in multi-package mapping, forwarding to " <> home + Just sourceLocation -> do + home <- resolveAndUnpackSourceLocation miState sourceLocation + logDebug miState $ "Found unit ID in multi-package mapping, forwarding to " <> unPackageHome home let method = LSP.SCustomMethod "daml/gotoDefinitionByName" lspId = maybe (error "No LspId provided back from tryGetDefinition") castLspId _id - putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) lspId method - sendSubIDEByPath miState home $ LSP.FromClientMess method $ LSP.ReqMess $ - LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $ - GotoDefinitionByNameParams loc name + msg = LSP.FromClientMess method $ LSP.ReqMess $ + LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $ + GotoDefinitionByNameParams loc name + sendSubIDEByPath miState (unPackageHome home) msg -- See STextDocumentDefinition in client handle for description of this path LSP.FromServerRsp (LSP.SCustomMethod "daml/gotoDefinitionByName") LSP.ResponseMessage {_id, _result} -> do - debugPrint miState "Got gotoDefinitionByName response, handling..." + logDebug miState "Got gotoDefinitionByName response, handling..." let parsedResult = parseCustomResult @GotoDefinitionByNameResult "daml/gotoDefinitionByName" _result reply :: Either LSP.ResponseError (LSP.ResponseResult 'LSP.TextDocumentDefinition) -> IO () reply rsp = do - debugPrint miState $ "Replying directly to client with " <> show rsp + logDebug miState $ "Replying directly to client with " <> show rsp sendClient miState $ LSP.FromServerRsp LSP.STextDocumentDefinition $ LSP.ResponseMessage "2.0" (castLspId <$> _id) rsp case parsedResult of Left err -> reply $ Left err Right loc -> reply $ Right $ LSP.InR $ LSP.InL $ LSP.List [loc] LSP.FromServerMess method _ -> do - debugPrint miState $ "Backwarding request " <> show method + logDebug miState $ "Backwarding request " <> show method <> ":\n" <> show msg sendClient miState msg LSP.FromServerRsp method _ -> do - debugPrint miState $ "Backwarding response to " <> show method + logDebug miState $ "Backwarding response to " <> show method <> ":\n" <> show msg sendClient miState msg -clientMessageHandler :: MultiIdeState -> B.ByteString -> IO () -clientMessageHandler miState bs = do - debugPrint miState "Called clientMessageHandler" +handleOpenFilesNotification + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Notification) + . MultiIdeState + -> LSP.NotificationMessage m + -> FilePath + -> IO () +handleOpenFilesNotification miState mess path = atomically $ case (mess ^. LSP.method, takeExtension path) of + (LSP.STextDocumentDidOpen, ".daml") -> getSourceFileHome miState path >>= traverse_ (\home -> addOpenFile miState home $ DamlFile path) + (LSP.STextDocumentDidClose, ".daml") -> getSourceFileHome miState path >>= traverse_ (\home -> removeOpenFile miState home $ DamlFile path) + _ -> pure () + +clientMessageHandler :: MultiIdeState -> IO () -> B.ByteString -> IO () +clientMessageHandler miState unblock bs = do + logInfo miState "Got new message from client" -- Decode a value, parse - let castFromClientMessage :: LSP.FromClientMessage' (Product LSP.SMethod (Const FilePath)) -> LSP.FromClientMessage + let castFromClientMessage :: LSP.FromClientMessage' SMethodWithSender -> LSP.FromClientMessage castFromClientMessage = \case LSP.FromClientMess method params -> LSP.FromClientMess method params - LSP.FromClientRsp (Pair method _) params -> LSP.FromClientRsp method params + LSP.FromClientRsp (SMethodWithSender method _) params -> LSP.FromClientRsp method params val :: Aeson.Value val = er "eitherDecode" $ Aeson.eitherDecodeStrict bs @@ -380,18 +571,25 @@ clientMessageHandler miState bs = do -- Store the initialize params for starting subIDEs, respond statically with what ghc-ide usually sends. LSP.FromClientMess LSP.SInitialize LSP.RequestMessage {_id, _method, _params} -> do putMVar (initParamsVar miState) _params - sendClient miState $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) (Right initializeResult) + -- Send initialized out first (skipping the queue), then unblock for other messages + sendClientFirst miState $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) (Right initializeResult) + unblock + + -- Register watchers for daml.yaml, multi-package.yaml and *.dar files + let LSP.RequestMessage {_id, _method} = registerFileWatchersMessage + putReqMethodSingleFromServerCoordinator (fromServerMethodTrackerVar miState) _id _method + + sendClient miState $ LSP.FromServerMess _method registerFileWatchersMessage + LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel notif -> do let (newNotif, mPrefix) = stripWorkDoneProgressCancelTokenPrefix notif newMsg = LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel newNotif -- Find IDE with the correct prefix, send to it if it exists. If it doesn't, the message can be thrown away. case mPrefix of Nothing -> void $ sendAllSubIDEs miState newMsg - Just prefix -> atomically $ do - ides <- takeTMVar $ subIDEsVar miState - let mIde = find (\ide -> ideMessageIdPrefix ide == prefix) $ onlyActiveSubIdes ides - traverse_ (`unsafeSendSubIDESTM` newMsg) mIde - putTMVar (subIDEsVar miState) ides + Just prefix -> holdingIDEsAtomic miState $ \ides -> + let mIde = find (\ideData -> (ideMessageIdPrefix <$> ideDataMain ideData) == Just prefix) ides + in traverse_ (`unsafeSendSubIDESTM` newMsg) $ mIde >>= ideDataMain -- Special handing for STextDocumentDefinition to ask multiple IDEs (the W approach) -- When a getDefinition is requested, we cast this request into a tryGetDefinition @@ -404,58 +602,102 @@ clientMessageHandler miState bs = do -- can't find the definition, it'll fall back to the known incorrect location. -- Once we have this, we return it as a response to the original STextDocumentDefinition request. LSP.FromClientMess LSP.STextDocumentDefinition req@LSP.RequestMessage {_id, _method, _params} -> do - let path = filePathFromParamsWithTextDocument req + let path = filePathFromParamsWithTextDocument miState req lspId = castLspId _id method = LSP.SCustomMethod "daml/tryGetDefinition" - putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) lspId method - sendSubIDEByPath miState path $ LSP.FromClientMess method $ LSP.ReqMess $ - LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $ - TryGetDefinitionParams (_params ^. LSP.textDocument) (_params ^. LSP.position) + msg = LSP.FromClientMess method $ LSP.ReqMess $ + LSP.RequestMessage "2.0" lspId method $ Aeson.toJSON $ + TryGetDefinitionParams (_params ^. LSP.textDocument) (_params ^. LSP.position) + logDebug miState "forwarding STextDocumentDefinition as daml/tryGetDefinition" + sendSubIDEByPath miState path msg + + -- Watched file changes, used for restarting subIDEs and changing coordinator state + LSP.FromClientMess LSP.SWorkspaceDidChangeWatchedFiles msg@LSP.NotificationMessage {_params = LSP.DidChangeWatchedFilesParams (LSP.List changes)} -> do + let changedPaths = + mapMaybe (\event -> do + path <- LSP.uriToFilePath $ event ^. LSP.uri + -- Filter out any changes to unpacked dars, no reloading logic should happen there + guard $ not $ unpackedDarsLocation miState `isInfixOf` path + pure (path ,event ^. LSP.xtype) + ) changes + forM_ changedPaths $ \(changedPath, changeType) -> + case takeFileName changedPath of + "daml.yaml" -> do + let home = PackageHome $ takeDirectory changedPath + logInfo miState $ "daml.yaml change in " <> unPackageHome home <> ". Shutting down IDE" + sourceFileHomeDamlYamlChanged miState home + rebootIdeByHome miState home + void $ updatePackageData miState + "multi-package.yaml" -> do + logInfo miState "multi-package.yaml change." + void $ updatePackageData miState + _ | takeExtension changedPath == ".dar" -> do + let darFile = DarFile changedPath + logInfo miState $ ".dar file changed: " <> changedPath + idesToShutdown <- fromMaybe mempty . Map.lookup darFile <$> atomically (readTMVar $ darDependentPackagesVar miState) + logDebug miState $ "Shutting down following ides: " <> show idesToShutdown + traverse_ (lenientRebootIdeByHome miState) idesToShutdown + + void $ updatePackageData miState + -- for .daml, we remove entry from the sourceFileHome cache if the file is deleted (note that renames/moves are sent as delete then create) + _ | takeExtension changedPath == ".daml" && changeType == LSP.FcDeleted -> sourceFileHomeDeleted miState changedPath + _ -> pure () + logDebug miState "all not on filtered DidChangeWatchedFilesParams" + -- Filter down to only daml files and send those + let damlOnlyChanges = filter (maybe False (\path -> takeExtension path == ".daml") . LSP.uriToFilePath . view LSP.uri) changes + sendAllSubIDEs_ miState $ LSP.FromClientMess LSP.SWorkspaceDidChangeWatchedFiles $ LSP.params .~ LSP.DidChangeWatchedFilesParams (LSP.List damlOnlyChanges) $ msg + + LSP.FromClientMess LSP.SExit _ -> do + ides <- atomically $ readTMVar $ subIDEsVar miState + traverse_ (handleExit miState) $ Map.mapMaybe ideDataMain ides + -- Wait half a second for all the exit messages to be sent + threadDelay 500_000 + exitSuccess LSP.FromClientMess meth params -> - case getMessageForwardingBehaviour meth params of + case getMessageForwardingBehaviour miState meth params of ForwardRequest mess (Single path) -> do - debugPrint miState $ "single req on method " <> show meth <> " over path " <> path + logDebug miState $ "single req on method " <> show meth <> " over path " <> path let LSP.RequestMessage {_id, _method} = mess - putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) _id _method - sendSubIDEByPath miState path (castFromClientMessage msg) + msg' = castFromClientMessage msg + sendSubIDEByPath miState path msg' ForwardRequest mess (AllRequest combine) -> do - debugPrint miState $ "all req on method " <> show meth + logDebug miState $ "all req on method " <> show meth let LSP.RequestMessage {_id, _method} = mess - ides <- sendAllSubIDEs miState (castFromClientMessage msg) - putReqMethodAll (fromClientMethodTrackerVar miState) _id _method ides combine - - ForwardNotification _ (Single path) -> do - debugPrint miState $ "single not on method " <> show meth <> " over path " <> path + msg' = castFromClientMessage msg + ides <- sendAllSubIDEs miState msg' + if null ides + then sendClient miState $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) $ combine [] + else putReqMethodAll (fromClientMethodTrackerVar miState) _id _method msg' ides combine + + ForwardNotification mess (Single path) -> do + logDebug miState $ "single not on method " <> show meth <> " over path " <> path + handleOpenFilesNotification miState mess path + -- Notifications aren't stored, so failure to send can be ignored sendSubIDEByPath miState path (castFromClientMessage msg) ForwardNotification _ AllNotification -> do - debugPrint miState $ "all not on method " <> show meth + logDebug miState $ "all not on method " <> show meth sendAllSubIDEs_ miState (castFromClientMessage msg) ExplicitHandler handler -> do + logDebug miState "calling explicit handler" handler (sendClient miState) (sendSubIDEByPath miState) - LSP.FromClientRsp (Pair method (Const home)) rMsg -> - sendSubIDEByPath miState home $ LSP.FromClientRsp method $ + -- Responses to subIDEs + LSP.FromClientRsp (SMethodWithSender method (Just home)) rMsg -> + -- If a response fails, failure is acceptable as the subIDE can't be expecting a response if its dead + sendSubIDEByPath miState (unPackageHome home) $ LSP.FromClientRsp method $ rMsg & LSP.id %~ fmap stripLspPrefix - -getMultiPackageYamlMapping :: (String -> IO ()) -> IO MultiPackageYamlMapping -getMultiPackageYamlMapping debugPrint = do - -- TODO: this will find the "closest" multi-package.yaml, but in a case where we have multiple referring to each other, we'll not see the outer one - -- in that case, code jump won't work. Its unclear which the user would want, so we may want to prompt them with either closest or furthest (that links up) - mPkgConfig <- findMultiPackageConfig $ ProjectPath "." - case mPkgConfig of - Nothing -> - Map.empty <$ debugPrint "No multi-package.yaml found" - Just path -> do - debugPrint "Found multi-package.yaml" - withMultiPackageConfig path $ \multiPackage -> do - eUnitIds <- traverse unitIdFromDamlYaml (mpPackagePaths multiPackage) - let eMapping = Map.fromList . flip zip (mpPackagePaths multiPackage) <$> sequence eUnitIds - either throwIO pure eMapping + -- Responses to coordinator + LSP.FromClientRsp (SMethodWithSender method Nothing) LSP.ResponseMessage {_id, _result} -> + case (method, _id) of + (LSP.SClientRegisterCapability, Just (LSP.IdString "MultiIdeWatchedFiles")) -> + either (\err -> logError miState $ "Watched file registration failed with " <> show err) (const $ logDebug miState "Successfully registered watched files") _result + _ -> pure () {- +TODO: refactor multi-package.yaml discovery logic Expect a multi-package.yaml at the workspace root If we do not get one, we continue as normal (no popups) until the user attempts to open/use files in a different package to the first one When this occurs, this send a popup: @@ -463,50 +705,227 @@ If we do not get one, we continue as normal (no popups) until the user attempts OR tell me where the multi-package.yaml(s) is if the user provides multiple, we union that lookup, allowing "cross project boundary" jumps -} +-- Updates the unit-id to package/dar mapping, as well as the dar to dependent packages mapping +-- for any daml.yamls or dars that are invalid, the ide home paths are returned, and their data is not added to the mapping +updatePackageData :: MultiIdeState -> IO [PackageHome] +updatePackageData miState = do + logInfo miState "Updating package data" + let ideRoot = multiPackageHome miState + + -- Take locks, throw away current data + atomically $ do + void $ takeTMVar (multiPackageMappingVar miState) + void $ takeTMVar (darDependentPackagesVar miState) + + mPkgConfig <- findMultiPackageConfig $ ProjectPath ideRoot + case mPkgConfig of + Nothing -> do + logDebug miState "No multi-package.yaml found" + damlYamlExists <- doesFileExist $ ideRoot projectConfigName + if damlYamlExists + then do + logDebug miState "Found daml.yaml" + -- Treat a workspace with only daml.yaml as a multi-package project with only one package + deriveAndWriteMappings [PackageHome ideRoot] [] + else do + logDebug miState "No daml.yaml found either" + -- Without a multi-package or daml.yaml, no mappings can be made. Passing empty lists here will give empty mappings + deriveAndWriteMappings [] [] + Just path -> do + logDebug miState "Found multi-package.yaml" + (eRes :: Either SomeException [PackageHome]) <- try @SomeException $ withMultiPackageConfig path $ \multiPackage -> + deriveAndWriteMappings + (PackageHome . toPosixFilePath <$> mpPackagePaths multiPackage) + (DarFile . toPosixFilePath <$> mpDars multiPackage) + let multiPackagePath = toPosixFilePath $ unwrapProjectPath path "multi-package.yaml" + case eRes of + Right paths -> do + -- On success, clear any diagnostics on the multi-package.yaml + sendClient miState $ clearDiagnostics multiPackagePath + pure paths + Left err -> do + -- If the computation fails, the mappings may be empty, so ensure the TMVars have values + atomically $ do + void $ tryPutTMVar (multiPackageMappingVar miState) Map.empty + void $ tryPutTMVar (darDependentPackagesVar miState) Map.empty + -- Show the failure as a diagnostic on the multi-package.yaml + sendClient miState $ fullFileDiagnostic ("Error reading multi-package.yaml:\n" <> displayException err) multiPackagePath + pure [] + where + -- Gets the unit id of a dar if it can, caches result in stateT + -- Returns Nothing (and stores) if anything goes wrong (dar doesn't exist, dar isn't archive, dar manifest malformed, etc.) + getDarUnitId :: DarFile -> StateT (Map.Map DarFile (Maybe UnitId)) IO (Maybe UnitId) + getDarUnitId dep = do + cachedResult <- gets (Map.lookup dep) + case cachedResult of + Just res -> pure res + Nothing -> do + mUnitId <- lift $ fmap eitherToMaybe $ try @SomeException $ do + archive <- Zip.toArchive <$> BSL.readFile (unDarFile dep) + manifest <- either fail pure $ readDalfManifest archive + -- Manifest "packageName" is actually unit id + maybe (fail $ "data-dependency " <> unDarFile dep <> " missing a package name") (pure . UnitId) $ packageName manifest + modify' $ Map.insert dep mUnitId + pure mUnitId + + deriveAndWriteMappings :: [PackageHome] -> [DarFile] -> IO [PackageHome] + deriveAndWriteMappings packagePaths darPaths = do + packedMappingData <- flip runStateT mempty $ do + -- load cache with all multi-package dars, so they'll be present in darUnitIds + traverse_ getDarUnitId darPaths + fmap (bimap catMaybes catMaybes . unzip) $ forM packagePaths $ \packagePath -> do + mUnitIdAndDeps <- lift $ fmap eitherToMaybe $ unitIdAndDepsFromDamlYaml packagePath + case mUnitIdAndDeps of + Just (unitId, deps) -> do + allDepsValid <- isJust . sequence <$> traverse getDarUnitId deps + pure (if allDepsValid then Nothing else Just packagePath, Just (packagePath, unitId, deps)) + _ -> pure (Just packagePath, Nothing) + + let invalidHomes :: [PackageHome] + validPackageDatas :: [(PackageHome, UnitId, [DarFile])] + darUnitIds :: Map.Map DarFile (Maybe UnitId) + ((invalidHomes, validPackageDatas), darUnitIds) = packedMappingData + packagesOnDisk :: Map.Map UnitId PackageSourceLocation + packagesOnDisk = + Map.fromList $ (\(packagePath, unitId, _) -> (unitId, PackageOnDisk packagePath)) <$> validPackageDatas + darMapping :: Map.Map UnitId PackageSourceLocation + darMapping = + Map.fromList $ fmap (\(packagePath, unitId) -> (unitId, PackageInDar packagePath)) $ Map.toList $ Map.mapMaybe id darUnitIds + multiPackageMapping :: Map.Map UnitId PackageSourceLocation + multiPackageMapping = packagesOnDisk <> darMapping + darDependentPackages :: Map.Map DarFile (Set.Set PackageHome) + darDependentPackages = foldr + (\(packagePath, _, deps) -> Map.unionWith (<>) $ Map.fromList $ (,Set.singleton packagePath) <$> deps + ) Map.empty validPackageDatas + + logDebug miState $ "Setting multi package mapping to:\n" <> show multiPackageMapping + logDebug miState $ "Setting dar dependent packages to:\n" <> show darDependentPackages + atomically $ do + putTMVar (multiPackageMappingVar miState) multiPackageMapping + putTMVar (darDependentPackagesVar miState) darDependentPackages + + pure invalidHomes -- Main loop logic -runMultiIde :: MultiIdeVerbose -> IO () -runMultiIde multiIdeVerbose = do - let debugPrinter = makeDebugPrint $ getMultiIdeVerbose multiIdeVerbose - multiPackageMapping <- getMultiPackageYamlMapping debugPrinter - miState <- newMultiIdeState multiPackageMapping debugPrinter - - infoPrint $ "Running " <> (if getMultiIdeVerbose multiIdeVerbose then "with" else "without") <> " verbose flag." - debugPrint miState "Listening for bytes" +createDefaultPackage :: SdkVersion.Class.SdkVersioned => IO (PackageHome, IO ()) +createDefaultPackage = do + (toPosixFilePath -> defaultPackagePath, cleanup) <- newTempDir + writeFile (defaultPackagePath "daml.yaml") $ unlines + [ "sdk-version: " <> SdkVersion.Class.sdkVersion + , "name: daml-ide-default-environment" + , "version: 1.0.0" + , "source: ." + , "dependencies:" + , " - daml-prim" + , " - daml-stdlib" + ] + pure (PackageHome defaultPackagePath, cleanup) + +runMultiIde :: SdkVersion.Class.SdkVersioned => Logger.Priority -> [String] -> IO () +runMultiIde loggingThreshold args = do + homePath <- toPosixFilePath <$> getCurrentDirectory + (defaultPackagePath, cleanupDefaultPackage) <- createDefaultPackage + let subIdeArgs = if loggingThreshold <= Logger.Debug then "--debug" : args else args + miState <- newMultiIdeState homePath defaultPackagePath loggingThreshold subIdeArgs + invalidPackageHomes <- updatePackageData miState + + -- Ensure we don't send messages to the client until it finishes initializing + (onceUnblocked, unblock) <- makeIOBlocker + + logInfo miState $ "Running with logging threshold of " <> show loggingThreshold -- Client <- ***** - toClientThread <- async $ forever $ do + toClientThread <- async $ onceUnblocked $ forever $ do msg <- atomically $ readTChan $ toClientChan miState - debugPrint miState "Pushing message to client" - -- BSLC.hPutStrLn stderr msg + logDebug miState $ "Pushing message to client:\n" <> BSLC.unpack msg putChunk stdout msg -- Client -> Coord clientToCoordThread <- async $ - onChunks stdin $ clientMessageHandler miState + onChunks stdin $ clientMessageHandler miState unblock + + -- All invalid packages get spun up, so their errors are shown + traverse_ (\home -> addNewSubIDEAndSend miState home Nothing) invalidPackageHomes let killAll :: IO () killAll = do - debugPrint miState "Killing subIDEs" - subIDEs <- atomically $ onlyActiveSubIdes <$> readTMVar (subIDEsVar miState) - forM_ subIDEs (shutdownIde miState) - infoPrint "MultiIde shutdown" - - handle (\(_ :: AsyncException) -> killAll) $ do - atomically $ do - unsafeIOToSTM $ debugPrint miState "Running main loop" + logDebug miState "Killing subIDEs" + holdingIDEs miState $ \ides -> foldM (unsafeShutdownIdeByHome miState) ides (Map.keys ides) + logInfo miState "MultiIde shutdown" + + -- Get all outcomes from a SubIDEInstance (process and async failures/completions) + subIdeInstanceOutcomes :: PackageHome -> SubIDEInstance -> STM [(PackageHome, SubIDEInstance, Either ExitCode SomeException)] + subIdeInstanceOutcomes home ide = do + mExitCode <- getExitCodeSTM (ideProcess ide) + errs <- lefts . catMaybes <$> traverse pollSTM [ideInhandleAsync ide, ideOutHandleAsync ide, ideErrTextAsync ide] + let mExitOutcome = (home, ide, ) . Left <$> mExitCode + errorOutcomes = (home, ide, ) . Right <$> errs + pure $ errorOutcomes <> maybeToList mExitOutcome + + -- Function folded over outcomes to update SubIDEs, keep error list and list subIDEs to reboot + handleOutcome + :: ([(PackageHome, SomeException)], SubIDEs, [PackageHome]) + -> (PackageHome, SubIDEInstance, Either ExitCode SomeException) + -> IO ([(PackageHome, SomeException)], SubIDEs, [PackageHome]) + handleOutcome (errs, subIDEs, toRestart) (home, ide, outcomeType) = + case outcomeType of + -- subIDE process exits + Left exitCode -> do + logDebug miState $ "SubIDE at " <> unPackageHome home <> " exited, cleaning up." + traverse_ hTryClose [ideInHandle ide, ideOutHandle ide, ideErrHandle ide] + traverse_ cancel [ideInhandleAsync ide, ideOutHandleAsync ide, ideErrTextAsync ide] + stderrContent <- T.unpack <$> readTVarIO (ideErrText ide) + currentTime <- getCurrentTime + let ideData = lookupSubIde home subIDEs + isMainIde = ideDataMain ideData == Just ide + isCrash = exitCode /= ExitSuccess + ideData' = ideData + { ideDataClosing = Set.delete ide $ ideDataClosing ideData + , ideDataMain = if isMainIde then Nothing else ideDataMain ideData + , ideDataFailTimes = + if isCrash && isMainIde + then take 2 $ currentTime : ideDataFailTimes ideData + else ideDataFailTimes ideData + , ideDataLastError = if isCrash && isMainIde then Just stderrContent else Nothing + } + toRestart' = if isCrash && isMainIde then home : toRestart else toRestart + when (isCrash && isMainIde) $ + logWarning miState $ "Proccess failed, stderr content:\n" <> stderrContent + + pure (errs, Map.insert home ideData' subIDEs, toRestart') + -- handler thread errors + Right exception -> pure ((home, exception) : errs, subIDEs, toRestart) + + forever $ do + (outcomes, clientThreadExceptions) <- atomically $ do subIDEs <- readTMVar $ subIDEsVar miState - let asyncs = concatMap (\subIDE -> [ideInhandleAsync subIDE, ideOutHandleAsync subIDE]) subIDEs - errs <- lefts . catMaybes <$> traverse pollSTM (asyncs ++ [toClientThread, clientToCoordThread]) - when (not $ null errs) $ - unsafeIOToSTM $ warnPrint $ "A thread handler errored with: " <> show (head errs) - - let procs = ideProcess <$> subIDEs - exits <- catMaybes <$> traverse getExitCodeSTM (Map.elems procs) - when (not $ null exits) $ - unsafeIOToSTM $ warnPrint $ "A subIDE finished with code: " <> show (head exits) - - when (null exits && null errs) retry - - -- If we get here, something failed/stopped, so stop everything - killAll + + outcomes <- fmap concat $ forM (Map.toList subIDEs) $ \(home, subIdeData) -> do + mainSubIdeOutcomes <- maybe (pure []) (subIdeInstanceOutcomes home) $ ideDataMain subIdeData + closingSubIdesOutcomes <- concat <$> traverse (subIdeInstanceOutcomes home) (Set.toList $ ideDataClosing subIdeData) + pure $ mainSubIdeOutcomes <> closingSubIdesOutcomes + + clientThreadExceptions <- lefts . catMaybes <$> traverse pollSTM [toClientThread, clientToCoordThread] + + when (null outcomes && null clientThreadExceptions) retry + + pure (outcomes, clientThreadExceptions) + + unless (null clientThreadExceptions) $ + if any (\e -> fromException @ExitCode e == Just ExitSuccess) clientThreadExceptions + then do + logWarning miState "Exiting!" + cleanupDefaultPackage + exitSuccess + else error $ "1 or more client thread handlers failed: " <> show clientThreadExceptions + + unless (null outcomes) $ do + errs <- withIDEs miState $ \ides -> do + (errs, ides', idesToRestart) <- foldM handleOutcome ([], ides, []) outcomes + ides'' <- foldM (\ides home -> unsafeAddNewSubIDEAndSend miState ides home Nothing) ides' idesToRestart + pure (ides'', errs) + + when (not $ null errs) $ do + cleanupDefaultPackage + killAll + error $ "SubIDE handlers failed with following errors:\n" <> unlines ((\(home, err) -> unPackageHome home <> " => " <> show err) <$> errs) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/DarDependencies.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/DarDependencies.hs new file mode 100644 index 000000000000..dca24f63da0f --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/DarDependencies.hs @@ -0,0 +1,199 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module DA.Cli.Damlc.Command.MultiIde.DarDependencies (resolveSourceLocation, unpackDar, unpackedDarsLocation) where + +import "zip-archive" Codec.Archive.Zip (Archive (..), Entry(..), toArchive, toEntry, fromArchive, fromEntry, findEntryByPath, deleteEntryFromArchive) +import Control.Monad (forM_, void) +import DA.Cli.Damlc.Command.MultiIde.Types (MultiIdeState (..), PackageSourceLocation (..), PackageHome (..), DarFile (..), logDebug, logInfo) +import DA.Daml.Compiler.Dar (breakAt72Bytes, mkConfFile) +import qualified DA.Daml.LF.Ast.Base as LF +import qualified DA.Daml.LF.Ast.Version as LF +import DA.Daml.LF.Proto3.Archive (DecodingMode (..), decodeArchive) +import DA.Daml.LF.Reader (DalfManifest(..), readManifest, readDalfManifest) +import DA.Daml.Project.Consts (projectConfigName) +import Data.Bifunctor (second) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSLC +import qualified Data.ByteString as BS +import Data.List (delete, intercalate, isPrefixOf) +import Data.List.Extra (lastDef, unsnoc) +import Data.List.Split (splitOn) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.NameMap as NM +import qualified Data.Text as T +import Data.Tuple.Extra (fst3, thd3) +import System.Directory (createDirectoryIfMissing, doesFileExist, removePathForcibly) +import System.FilePath.Posix + +import qualified Module as Ghc + +-- Given a dar, attempts to recreate the package structure for the IDE, with all files set to read-only. +-- Note, this function deletes the previous folder for the same unit-id, ensure subIDE is not running in this directory +-- before calling this function +unpackDar :: MultiIdeState -> DarFile -> IO () +unpackDar miState darFile = do + let darPath = unDarFile darFile + logInfo miState $ "Unpacking dar: " <> darPath + archiveWithSource <- toArchive <$> BSL.readFile darPath + manifest <- either fail pure $ readDalfManifest archiveWithSource + rawManifest <- either fail pure $ readManifest archiveWithSource + let (archive, damlFiles) = extractDarSourceFiles archiveWithSource + + mainDalf <- maybe (fail "Couldn't find main dalf in dar") pure $ findEntryByPath (mainDalfPath manifest) archive + + let (mainPkgName, mainPkgVersion, mainPackageId) = extractPackageMetadataFromEntry mainDalf + darUnpackLocation = unPackageHome $ unpackedDarPath miState mainPkgName mainPkgVersion + + -- Clear the unpack location + removePathForcibly darUnpackLocation + + -- Write packageId file + createDirectoryIfMissing True (darUnpackLocation ".daml") + writeFile (darUnpackLocation ".daml" mainPackageId) "" + + void $ flip Map.traverseWithKey damlFiles $ \path content -> do + let fullPath = darUnpackLocation "daml" path + createDirectoryIfMissing True (takeDirectory fullPath) + BSL.writeFile fullPath content + + let mainDalfContent = BSL.toStrict $ fromEntry mainDalf + ignoredPrefixes = ["daml-stdlib", "daml-prim", "daml-script", "daml3-script", mainPkgName <> "-" <> mainPkgVersion] + -- Filter dalfs first such that none start with `daml-stdlib` or `daml-prim`, `daml-script` or `daml3-script` + -- then that the package id of the dalf isn't in the LF for the main package + dalfsToExpand = + flip filter (zEntries archive) $ \entry -> + takeExtension (eRelativePath entry) == ".dalf" + && not (any (\prefix -> prefix `isPrefixOf` takeBaseName (eRelativePath entry)) ignoredPrefixes) + && BS.isInfixOf (BSC.pack $ thd3 $ extractPackageMetadataFromEntry entry) mainDalfContent + -- Rebuild dalfs into full dars under dars directory + darDepArchives = + fmap (\entry -> + ( darUnpackLocation "dars" takeBaseName (eRelativePath entry) <.> "dar" + , rebuildDarFromDalfEntry archive rawManifest (dalfPaths manifest) (eRelativePath mainDalf) entry + ) + ) dalfsToExpand + + -- Write dar files + forM_ darDepArchives $ \(path, archive) -> do + createDirectoryIfMissing True (takeDirectory path) + BSL.writeFile path $ fromArchive archive + + (_, mainPkg) <- either (fail . show) pure $ decodeArchive DecodeAsMain mainDalfContent + + let isSdkPackage pkgName entry = + takeExtension (eRelativePath entry) == ".dalf" && pkgName == fst3 (extractPackageMetadataFromEntry entry) + includesSdkPackage pkgName = any (isSdkPackage pkgName) $ zEntries archive + sdkPackages = ["daml-script", "daml3-script", "daml-trigger"] + deps = ["daml-prim", "daml-stdlib"] <> filter includesSdkPackage sdkPackages + damlYamlContent = unlines $ + [ "sdk-version: " <> sdkVersion manifest + , "name: " <> T.unpack (LF.unPackageName $ LF.packageName $ LF.packageMetadata mainPkg) + , "version: " <> T.unpack (LF.unPackageVersion $ LF.packageVersion $ LF.packageMetadata mainPkg) + , "source: daml" + , "build-options:" + , " - --target=" <> LF.renderVersion (LF.packageLfVersion mainPkg) + , "dependencies:" + ] + <> fmap (" - " <>) deps + <> ["data-dependencies: "] + <> fmap (\(path, _) -> " - " <> makeRelative darUnpackLocation path) darDepArchives + + writeFile (darUnpackLocation projectConfigName) damlYamlContent + +extractPackageMetadataFromEntry :: Entry -> (String, String, String) +extractPackageMetadataFromEntry = extractPackageMetadataFromDalfPath . eRelativePath + +-- Gives back name, version, package hash +-- TODO: Ensure this information is always here and of this form +extractPackageMetadataFromDalfPath :: FilePath -> (String, String, String) +extractPackageMetadataFromDalfPath path = + case unsnoc $ splitOn "-" $ takeBaseName path of + Just ([name], hash) -> (name, "", hash) + Just (sections, hash) -> (intercalate "-" $ init sections, lastDef "" sections, hash) + _ -> ("", "", "") + +unpackedDarsLocation :: MultiIdeState -> FilePath +unpackedDarsLocation miState = multiPackageHome miState ".daml" "unpacked-dars" + +unpackedDarPath :: MultiIdeState -> String -> String -> PackageHome +unpackedDarPath miState pkgName pkgVersion = PackageHome $ unpackedDarsLocation miState pkgName <> "-" <> pkgVersion + +-- Pull out every daml file into a mapping from path to content +-- Return an archive without these files or any hi/hie files +extractDarSourceFiles :: Archive -> (Archive, Map FilePath BSL.ByteString) +extractDarSourceFiles archive = foldr handleEntry (archive, Map.empty) $ zEntries archive + where + handleEntry :: Entry -> (Archive, Map FilePath BSL.ByteString) -> (Archive, Map FilePath BSL.ByteString) + handleEntry entry (archive', damlFiles) = + case takeExtension $ eRelativePath entry of + ".daml" -> (deleteEntryFromArchive (eRelativePath entry) archive', Map.insert (joinPath $ tail $ splitPath $ eRelativePath entry) (fromEntry entry) damlFiles) + ".hi" -> (deleteEntryFromArchive (eRelativePath entry) archive', damlFiles) + ".hie" -> (deleteEntryFromArchive (eRelativePath entry) archive', damlFiles) + _ -> (archive', damlFiles) + +-- Recreate the conf file from a dalf +readDalfConf :: Entry -> (FilePath, BSL.ByteString) +readDalfConf entry = + let (pkgId :: LF.PackageId, pkg :: LF.Package) = either (error . show) id $ decodeArchive DecodeAsMain $ BSL.toStrict $ fromEntry entry + moduleNames :: [Ghc.ModuleName] + moduleNames = Ghc.mkModuleName . T.unpack . T.intercalate "." . LF.unModuleName <$> NM.names (LF.packageModules pkg) + pkgName :: LF.PackageName + pkgName = LF.packageName $ LF.packageMetadata pkg + pkgVersion :: LF.PackageVersion + pkgVersion = LF.packageVersion $ LF.packageMetadata pkg + -- TODO[SW]: the `depends` list is empty right now, as we don't have the full dar dependency tree. + in second BSL.fromStrict $ mkConfFile pkgName (Just pkgVersion) [] Nothing moduleNames pkgId + +-- Copies all dalf files over, changing their directory to match the new main package +-- Updates the Name, Main-Dalf and Dalfs fields in the manifest to reflect the new main package/dalf locations +-- Updates the /data/.conf file to reflect the new package (note that the "depends" field is a little tricky) +rebuildDarFromDalfEntry :: Archive -> [(BS.ByteString, BS.ByteString)] -> [FilePath] -> FilePath -> Entry -> Archive +rebuildDarFromDalfEntry archive rawManifest dalfPaths topDalfPath mainEntry = archive {zEntries = mapMaybe mapEntry $ zEntries archive} + where + mapEntry :: Entry -> Maybe Entry + mapEntry entry = + case takeExtension $ eRelativePath entry of + -- Need to remove the top level dar + ".dalf" | eRelativePath entry == topDalfPath -> Nothing + ".dalf" -> Just $ entry {eRelativePath = updatePathToMainEntry $ eRelativePath entry} + ".MF" -> Just $ toEntry (eRelativePath entry) (eLastModified entry) $ serialiseRawManifest $ overwriteRawManifestFields rawManifest + [ ("Name", BSC.pack mainEntryId) + , ("Main-Dalf", BSC.pack $ updatePathToMainEntry $ eRelativePath mainEntry) + , ("Dalfs", BS.intercalate ", " $ BSC.pack . updatePathToMainEntry <$> dalfPathsWithoutTop) + ] + ".conf" -> + let (confFileName, confContent) = readDalfConf mainEntry + in Just $ toEntry + (mainEntryName "data" confFileName) + (eLastModified entry) + confContent + _ -> Just entry + dalfPathsWithoutTop = delete topDalfPath dalfPaths + mainEntryName = takeBaseName $ eRelativePath mainEntry + mainEntryId = intercalate "-" $ init $ splitOn "-" mainEntryName + updatePathToMainEntry = joinPath . (mainEntryName :) . tail . splitPath + serialiseRawManifest :: [(BS.ByteString, BS.ByteString)] -> BSL.ByteString + serialiseRawManifest = BSLC.unlines . map (\(k, v) -> breakAt72Bytes $ BSL.fromStrict $ k <> ": " <> v) + overwriteRawManifestFields :: [(BS.ByteString, BS.ByteString)] -> [(BS.ByteString, BS.ByteString)] -> [(BS.ByteString, BS.ByteString)] + overwriteRawManifestFields original overwrites' = fmap (\(k, v) -> (k, fromMaybe v $ Map.lookup k overwrites)) original + where + overwrites = Map.fromList overwrites' + +-- Resolves the source location of a package location to a path, alongside an optional path to a dar to unpack first +resolveSourceLocation :: MultiIdeState -> PackageSourceLocation -> IO (PackageHome, Maybe DarFile) +resolveSourceLocation _ (PackageOnDisk path) = pure (path, Nothing) +resolveSourceLocation miState (PackageInDar darPath) = do + logDebug miState "Looking for unpacked dar" + archive <- toArchive <$> BSL.readFile (unDarFile darPath) + manifest <- either fail pure $ readDalfManifest archive + let (pkgName, pkgVersion, pkgId) = extractPackageMetadataFromDalfPath $ mainDalfPath manifest + pkgPath = unpackedDarPath miState pkgName pkgVersion + pkgIdTagPath = unPackageHome pkgPath ".daml" pkgId + + pkgExists <- doesFileExist pkgIdTagPath + + pure (pkgPath, if pkgExists then Nothing else Just darPath) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs index 82c7cc538746..c36913ec1584 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs @@ -51,7 +51,7 @@ pullMonadThroughTuple (a, mb) = (a,) <$> mb -- Takes a natural transformation of responses and lifts it to forward the first error assumeSuccessCombiner :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) - . ([(FilePath, LSP.ResponseResult m)] -> LSP.ResponseResult m) + . ([(PackageHome, LSP.ResponseResult m)] -> LSP.ResponseResult m) -> ResponseCombiner m assumeSuccessCombiner f res = f <$> mapM pullMonadThroughTuple res @@ -78,36 +78,37 @@ uriFilePathPrism = prism' LSP.filePathToUri LSP.uriToFilePath getMessageForwardingBehaviour :: forall t (m :: LSP.Method 'LSP.FromClient t) - . LSP.SMethod m + . MultiIdeState + -> LSP.SMethod m -> LSP.Message m -> Forwarding m -getMessageForwardingBehaviour meth params = +getMessageForwardingBehaviour miState meth params = case meth of LSP.SInitialize -> handleElsewhere "Initialize" LSP.SInitialized -> ignore -- send to all then const reply LSP.SShutdown -> ForwardRequest params $ AllRequest (assumeSuccessCombiner @m $ const LSP.Empty) - LSP.SExit -> ForwardNotification params AllNotification + LSP.SExit -> handleElsewhere "Exit" LSP.SWorkspaceDidChangeWorkspaceFolders -> ForwardNotification params AllNotification LSP.SWorkspaceDidChangeConfiguration -> ForwardNotification params AllNotification LSP.SWorkspaceDidChangeWatchedFiles -> ForwardNotification params AllNotification - LSP.STextDocumentDidOpen -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentDidChange -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentWillSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentWillSaveWaitUntil -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentDidSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentDidClose -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentCompletion -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentHover -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentSignatureHelp -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentDeclaration -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params + LSP.STextDocumentDidOpen -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentDidChange -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentWillSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentWillSaveWaitUntil -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentDidSave -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentDidClose -> ForwardNotification params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentCompletion -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentHover -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentSignatureHelp -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentDeclaration -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params LSP.STextDocumentDefinition -> handleElsewhere "TextDocumentDefinition" - LSP.STextDocumentDocumentSymbol -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentCodeAction -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentCodeLens -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentDocumentLink -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentColorPresentation -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params - LSP.STextDocumentOnTypeFormatting -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument params + LSP.STextDocumentDocumentSymbol -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentCodeAction -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentCodeLens -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentDocumentLink -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentColorPresentation -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params + LSP.STextDocumentOnTypeFormatting -> ForwardRequest params $ forwardingBehaviourFromParamsWithTextDocument miState params LSP.SCustomMethod "daml/keepAlive" -> case params of @@ -169,20 +170,25 @@ getMessageForwardingBehaviour meth params = LSP.STextDocumentSemanticTokensRange -> unsupported "TextDocumentSemanticTokensRange" LSP.SWorkspaceSemanticTokensRefresh -> unsupported "WorkspaceSemanticTokensRefresh" -filePathFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => p -> FilePath -filePathFromParamsWithTextDocument params = +filePathFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => MultiIdeState -> p -> FilePath +filePathFromParamsWithTextDocument miState params = let uri = params ^. LSP.params . LSP.textDocument . LSP.uri - in fromMaybe (error $ "Failed to extract path: " <> show uri) $ filePathFromURI uri + in fromMaybe (error $ "Failed to extract path: " <> show uri) $ filePathFromURI miState uri -forwardingBehaviourFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => p -> ForwardingBehaviour m -forwardingBehaviourFromParamsWithTextDocument params = Single $ filePathFromParamsWithTextDocument params +forwardingBehaviourFromParamsWithTextDocument :: (LSP.HasParams p a, LSP.HasTextDocument a t, LSP.HasUri t LSP.Uri) => MultiIdeState -> p -> ForwardingBehaviour m +forwardingBehaviourFromParamsWithTextDocument miState params = Single $ filePathFromParamsWithTextDocument miState params -- Attempts to convert the URI directly to a filepath -- If the URI is a virtual resource, we instead parse it as such and extract the file from that -filePathFromURI :: LSP.Uri -> Maybe FilePath -filePathFromURI uri = +filePathFromURI :: MultiIdeState -> LSP.Uri -> Maybe FilePath +filePathFromURI miState uri = LSP.uriToFilePath uri <|> do parsedUri <- URI.parseURI $ T.unpack $ LSP.getUri uri - vr <- uriToVirtualResource parsedUri - pure $ LSP.fromNormalizedFilePath $ vrScenarioFile vr + case URI.uriScheme parsedUri of + "daml:" -> do + vr <- uriToVirtualResource parsedUri + pure $ LSP.fromNormalizedFilePath $ vrScenarioFile vr + "untitled:" -> + pure $ unPackageHome $ defaultPackagePath miState + _ -> Nothing diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs index d124c265aa08..33b2012bd681 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs @@ -10,6 +10,8 @@ {-# LANGUAGE GADTs #-} module DA.Cli.Damlc.Command.MultiIde.Parsing ( + getUnrespondedRequestsToResend, + getUnrespondedRequestsFallbackResponses, onChunks, parseClientMessageWithTracker, parseServerMessageWithTracker, @@ -17,7 +19,9 @@ module DA.Cli.Damlc.Command.MultiIde.Parsing ( putReqMethodAll, putReqMethodSingleFromClient, putReqMethodSingleFromServer, - putServerReq, + putReqMethodSingleFromServerCoordinator, + putFromServerMessage, + putSingleFromClientMessage, ) where import Control.Concurrent.STM.TVar @@ -31,12 +35,18 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Foldable (forM_) import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Cli.Damlc.Command.MultiIde.Util +import Data.Bifunctor (second) import Data.Functor.Product import qualified Data.IxMap as IM import Data.List (delete) +import qualified Data.Map as Map import Data.Maybe (fromMaybe) +import Data.Some.Newtype (Some, mkSome, withSome) import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP import System.IO.Extra +import Unsafe.Coerce (unsafeCoerce) -- Missing from Data.Attoparsec.ByteString.Lazy, copied from Data.Attoparsec.ByteString.Char8 decimal :: Attoparsec.Parser Int @@ -51,11 +61,13 @@ contentChunkParser = do Attoparsec.take len -- Runs a handler on chunks as they come through the handle +-- Returns an error string on failure onChunks :: Handle -> (B.ByteString -> IO ()) -> IO () onChunks handle act = let handleResult bytes = case Attoparsec.parse contentChunkParser bytes of Attoparsec.Done leftovers result -> act result >> handleResult leftovers + Attoparsec.Fail _ _ "not enough input" -> pure () Attoparsec.Fail _ _ err -> error $ "Chunk parse failed: " <> err in BSL.hGetContents handle >>= handleResult @@ -63,28 +75,52 @@ putChunk :: Handle -> BSL.ByteString -> IO () putChunk handle payload = do let fullMessage = "Content-Length: " <> BSLC.pack (show (BSL.length payload)) <> "\r\n\r\n" <> payload BSL.hPut handle fullMessage - hFlush handle + hTryFlush handle putReqMethodSingleFromServer :: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request) - . MethodTrackerVar 'LSP.FromServer -> FilePath -> LSP.LspId m -> LSP.SMethod m -> IO () -putReqMethodSingleFromServer tracker home id method = putReqMethod tracker id $ TrackedSingleMethodFromServer method home + . MethodTrackerVar 'LSP.FromServer -> PackageHome -> LSP.LspId m -> LSP.SMethod m -> IO () +putReqMethodSingleFromServer tracker home id method = putReqMethod tracker id $ TrackedSingleMethodFromServer method $ Just home + +putReqMethodSingleFromServerCoordinator + :: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request) + . MethodTrackerVar 'LSP.FromServer -> LSP.LspId m -> LSP.SMethod m -> IO () +putReqMethodSingleFromServerCoordinator tracker id method = putReqMethod tracker id $ TrackedSingleMethodFromServer method Nothing + +-- Takes a message from server and stores it if its a request, so that later messages from the client can deduce response context +putFromServerMessage :: MultiIdeState -> PackageHome -> LSP.FromServerMessage -> IO () +putFromServerMessage miState home (LSP.FromServerMess method mess) = + case (LSP.splitServerMethod method, mess) of + (LSP.IsServerReq, _) -> putReqMethodSingleFromServer (fromServerMethodTrackerVar miState) home (mess ^. LSP.id) method + (LSP.IsServerEither, LSP.ReqMess mess) -> putReqMethodSingleFromServer (fromServerMethodTrackerVar miState) home (mess ^. LSP.id) method + _ -> pure () +putFromServerMessage _ _ _ = pure () putReqMethodSingleFromClient :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) - . MethodTrackerVar 'LSP.FromClient -> LSP.LspId m -> LSP.SMethod m -> IO () -putReqMethodSingleFromClient tracker id method = putReqMethod tracker id $ TrackedSingleMethodFromClient method + . MethodTrackerVar 'LSP.FromClient -> LSP.LspId m -> LSP.SMethod m -> LSP.FromClientMessage -> PackageHome -> IO () +putReqMethodSingleFromClient tracker id method message home = putReqMethod tracker id $ TrackedSingleMethodFromClient method message home + +-- Convenience wrapper around putReqMethodSingleFromClient +putSingleFromClientMessage :: MultiIdeState -> PackageHome -> LSP.FromClientMessage -> IO () +putSingleFromClientMessage miState home msg@(LSP.FromClientMess method mess) = + case (LSP.splitClientMethod method, mess) of + (LSP.IsClientReq, _) -> putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) (mess ^. LSP.id) method msg home + (LSP.IsClientEither, LSP.ReqMess mess) -> putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) (mess ^. LSP.id) method msg home + _ -> pure () +putSingleFromClientMessage _ _ _ = pure () putReqMethodAll :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) . MethodTrackerVar 'LSP.FromClient -> LSP.LspId m -> LSP.SMethod m - -> [FilePath] + -> LSP.FromClientMessage + -> [PackageHome] -> ResponseCombiner m -> IO () -putReqMethodAll tracker id method ides combine = - putReqMethod tracker id $ TrackedAllMethod method id combine ides [] +putReqMethodAll tracker id method msg ides combine = + putReqMethod tracker id $ TrackedAllMethod method id msg combine ides [] putReqMethod :: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request) @@ -121,22 +157,23 @@ wrapParseMessageLookup (mayTM, newIM) = -- Parses a message from the server providing context about previous requests from client -- allowing the server parser to reconstruct typed responses to said requests -- Handles TrackedAllMethod by returning Nothing for messages that do not have enough replies yet. -parseServerMessageWithTracker :: MethodTrackerVar 'LSP.FromClient -> FilePath -> Aeson.Value -> IO (Either String (Maybe LSP.FromServerMessage)) -parseServerMessageWithTracker tracker selfIde val = pickReqMethodTo tracker $ \extract -> +parseServerMessageWithTracker :: MethodTrackerVar 'LSP.FromClient -> PackageHome -> Aeson.Value -> IO (Either String (Maybe LSP.FromServerMessage)) +parseServerMessageWithTracker tracker home val = pickReqMethodTo tracker $ \extract -> case Aeson.parseEither (LSP.parseServerMessage (wrapParseMessageLookup . extract)) val of Right (LSP.FromServerMess meth mess) -> (Right (Just $ LSP.FromServerMess meth mess), Nothing) - Right (LSP.FromServerRsp (Pair (TrackedSingleMethodFromClient method) (Const newIxMap)) rsp) -> (Right (Just (LSP.FromServerRsp method rsp)), Just newIxMap) + Right (LSP.FromServerRsp (Pair (TrackedSingleMethodFromClient method _ _) (Const newIxMap)) rsp) -> (Right (Just (LSP.FromServerRsp method rsp)), Just newIxMap) -- Multi reply logic, for requests that are sent to all IDEs with responses unified. Required for some queries Right (LSP.FromServerRsp (Pair tm@TrackedAllMethod {} (Const newIxMap)) rsp) -> do -- Haskell gets a little confused when updating existential records, so we need to build a new one let tm' = TrackedAllMethod { tamMethod = tamMethod tm , tamLspId = tamLspId tm + , tamClientMessage = tamClientMessage tm , tamCombiner = tamCombiner tm - , tamResponses = (selfIde, LSP._result rsp) : tamResponses tm - , tamRemainingResponseIDERoots = delete selfIde $ tamRemainingResponseIDERoots tm + , tamResponses = (home, LSP._result rsp) : tamResponses tm + , tamRemainingResponsePackageHomes = delete home $ tamRemainingResponsePackageHomes tm } - if null $ tamRemainingResponseIDERoots tm' + if null $ tamRemainingResponsePackageHomes tm' then let msg = LSP.FromServerRsp (tamMethod tm) $ rsp {LSP._result = tamCombiner tm' (tamResponses tm')} in (Right $ Just msg, Just newIxMap) else let insertedIxMap = fromMaybe newIxMap $ IM.insertIxMap (tamLspId tm) tm' newIxMap @@ -149,26 +186,92 @@ parseServerMessageWithTracker tracker selfIde val = pickReqMethodTo tracker $ \e parseClientMessageWithTracker :: MethodTrackerVar 'LSP.FromServer -> Aeson.Value - -> IO (Either String (LSP.FromClientMessage' (Product LSP.SMethod (Const FilePath)))) + -> IO (Either String (LSP.FromClientMessage' SMethodWithSender)) parseClientMessageWithTracker tracker val = pickReqMethodTo tracker $ \extract -> case Aeson.parseEither (LSP.parseClientMessage (wrapParseMessageLookup . extract)) val of Right (LSP.FromClientMess meth mess) -> (Right (LSP.FromClientMess meth mess), Nothing) - Right (LSP.FromClientRsp (Pair (TrackedSingleMethodFromServer method home) (Const newIxMap)) rsp) -> - (Right (LSP.FromClientRsp (Pair method (Const home)) rsp), Just newIxMap) + Right (LSP.FromClientRsp (Pair (TrackedSingleMethodFromServer method mHome) (Const newIxMap)) rsp) -> + (Right (LSP.FromClientRsp (SMethodWithSender method mHome) rsp), Just newIxMap) Left msg -> (Left msg, Nothing) --- Takes a message from server and stores it if its a request, so that later messages from the client can deduce response context -putServerReq :: MethodTrackerVar 'LSP.FromServer -> FilePath -> LSP.FromServerMessage -> IO () -putServerReq tracker home msg = - case msg of - LSP.FromServerMess meth mess -> - case LSP.splitServerMethod meth of - LSP.IsServerReq -> - let LSP.RequestMessage {_id, _method} = mess - in putReqMethodSingleFromServer tracker home _id _method - LSP.IsServerEither -> - case mess of - LSP.ReqMess LSP.RequestMessage {_id, _method} -> putReqMethodSingleFromServer tracker home _id _method - _ -> pure () - _ -> pure () - _ -> pure () +-- Map.mapAccumWithKey where the replacement value is a Maybe. Accumulator is still updated for `Nothing` values +mapMaybeAccumWithKey :: Ord k => (a -> k -> b -> (a, Maybe c)) -> a -> Map.Map k b -> (a, Map.Map k c) +mapMaybeAccumWithKey f z = flip Map.foldrWithKey (z, Map.empty) $ \k v (accum, m) -> + second (maybe m (\v' -> Map.insert k v' m)) $ f accum k v + +-- Convenience for the longwinded FromClient Some TrackedMethod type +type SomeFromClientTrackedMethod = Some @(LSP.Method 'LSP.FromClient 'LSP.Request) TrackedMethod + +-- Sadly some coercions needed here, as IxMap doesn't expose methods to traverse the map safely +-- Each usage is explained in comments nearby +-- We disable the restricted `unsafeCoerce` warning below +{-# ANN adjustClientTrackers ("HLint: ignore Avoid restricted function" :: String) #-} +adjustClientTrackers + :: forall a + . MultiIdeState + -> PackageHome + -> ( forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . LSP.LspId m + -> TrackedMethod m + -> (Maybe (TrackedMethod m), Maybe a) + ) + -> IO [a] +adjustClientTrackers miState home adjuster = atomically $ stateTVar (fromClientMethodTrackerVar miState) $ \tracker -> + let doAdjust + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . [a] + -> LSP.LspId m + -> TrackedMethod m + -> ([a], Maybe SomeFromClientTrackedMethod) + doAdjust accum lspId tracker = let (mTracker, mV) = adjuster lspId tracker in (maybe accum (:accum) mV, mkSome <$> mTracker) + -- In this function, we unpack the SomeLspId to LspId m', then coerce the `m'` to match the `m` of TrackedMethod. + -- This invariant is enforced by the interface to IxMaps, and thus is safe. + adjust :: [a] -> LSP.SomeLspId -> SomeFromClientTrackedMethod -> ([a], Maybe SomeFromClientTrackedMethod) + adjust accum someLspId someTracker = withSome someTracker $ \tracker -> case (tracker, someLspId) of + (TrackedSingleMethodFromClient _ _ home', LSP.SomeLspId lspId) | home == home' -> doAdjust accum (unsafeCoerce lspId) tracker + (TrackedAllMethod {tamRemainingResponsePackageHomes}, LSP.SomeLspId lspId) | home `elem` tamRemainingResponsePackageHomes -> doAdjust accum (unsafeCoerce lspId) tracker + _ -> (accum, Just someTracker) + -- We know that the fromClientMethodTrackerVar only contains Trackers for FromClient, but this information is lost in the `Some` inside the IxMap + -- We define our `adjust` method safely, by having it know this `FromClient` constraint, then coerce it to bring said constraint into scope. + -- (trackerMap :: forall (from :: LSP.From). Map.Map SomeLspId (Some @(Lsp.Method from @LSP.Request) TrackedMethod)) + -- where `from` is constrained outside the IxMap and as such, enforced weakly (using unsafeCoerce) + (accum, trackerMap) = mapMaybeAccumWithKey (unsafeCoerce adjust) [] $ IM.getMap tracker + in (accum, IM.IxMap trackerMap) + +-- Checks if a given Shutdown or Initialize lspId is for an IDE that is still closing, and as such, should not be removed +isClosingIdeInFlight :: SubIDEData -> LSP.SMethod m -> LSP.LspId m -> Bool +isClosingIdeInFlight ideData LSP.SShutdown (LSP.IdString str) = any (\ide -> str == ideMessageIdPrefix ide <> "-shutdown") $ ideDataClosing ideData +isClosingIdeInFlight ideData LSP.SInitialize (LSP.IdString str) = any (\ide -> str == ideMessageIdPrefix ide <> "-init") $ ideDataClosing ideData +isClosingIdeInFlight _ _ _ = False + +-- Reads all unresponded messages for a given home, gives back the original messages. Ignores and deletes Initialize and Shutdown requests +-- but only if no ideClosing ides are using them +getUnrespondedRequestsToResend :: MultiIdeState -> SubIDEData -> PackageHome -> IO [LSP.FromClientMessage] +getUnrespondedRequestsToResend miState ideData home = adjustClientTrackers miState home $ \lspId tracker -> case tmMethod tracker of + -- Keep shutdown/initialize messages that are in use, but don't return them + method | isClosingIdeInFlight ideData method lspId -> (Just tracker, Nothing) + LSP.SInitialize -> (Nothing, Nothing) + LSP.SShutdown -> (Nothing, Nothing) + _ -> (Just tracker, Just $ tmClientMessage tracker) + +-- Gets fallback responses for all unresponded requests for a given home. +-- For Single IDE requests, we return noIDEReply, and delete the request from the tracker +-- For All IDE requests, we delete this home from the aggregate response, and if it is now complete, run the combiner and return the result +getUnrespondedRequestsFallbackResponses :: MultiIdeState -> SubIDEData -> PackageHome -> IO [LSP.FromServerMessage] +getUnrespondedRequestsFallbackResponses miState ideData home = adjustClientTrackers miState home $ \lspId tracker -> case tracker of +-- Keep shutdown/initialize messages that are in use, but don't return them + TrackedSingleMethodFromClient method _ _ | isClosingIdeInFlight ideData method lspId -> (Just tracker, Nothing) + TrackedSingleMethodFromClient _ msg _ -> (Nothing, noIDEReply msg) + tm@TrackedAllMethod {tamRemainingResponsePackageHomes = [home']} | home' == home -> + let reply = LSP.FromServerRsp (tamMethod tm) $ LSP.ResponseMessage "2.0" (Just $ tamLspId tm) (tamCombiner tm $ tamResponses tm) + in (Nothing, Just reply) + TrackedAllMethod {..} -> + let tm = TrackedAllMethod + { tamMethod + , tamLspId + , tamClientMessage + , tamCombiner + , tamResponses + , tamRemainingResponsePackageHomes = delete home tamRemainingResponsePackageHomes + } + in (Just tm, Nothing) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs index e6cf1c9cc037..d950a2a09484 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs @@ -206,7 +206,7 @@ stripLspPrefix (LSP.IdString (T.uncons -> Just ('t', rest))) = LSP.IdString $ T. stripLspPrefix t = t -- Prefixes applied to builtin and custom requests. Notifications do not have ids, responses do not need this logic. -addLspPrefixToServerMessage :: SubIDE -> LSP.FromServerMessage -> LSP.FromServerMessage +addLspPrefixToServerMessage :: SubIDEInstance -> LSP.FromServerMessage -> LSP.FromServerMessage addLspPrefixToServerMessage _ res@(LSP.FromServerRsp _ _) = res addLspPrefixToServerMessage ide res@(LSP.FromServerMess method params) = case LSP.splitServerMethod method of diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs index 488b9b6acd48..45c412e91bb8 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs @@ -18,82 +18,181 @@ import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TMVar import Control.Concurrent.MVar +import Control.Monad (void) import Control.Monad.STM +import DA.Daml.Project.Types (ProjectPath (..)) import qualified Data.ByteString.Lazy as BSL +import Data.Function (on) import qualified Data.IxMap as IM import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) import qualified Language.LSP.Types as LSP import System.IO.Extra import System.Process.Typed (Process) +import qualified DA.Service.Logger as Logger +import qualified DA.Service.Logger.Impl.IO as Logger + +newtype PackageHome = PackageHome {unPackageHome :: FilePath} deriving (Show, Eq, Ord) + +toProjectPath :: PackageHome -> ProjectPath +toProjectPath (PackageHome path) = ProjectPath path + +newtype DarFile = DarFile {unDarFile :: FilePath} deriving (Show, Eq, Ord) +newtype DamlFile = DamlFile {unDamlFile :: FilePath} deriving (Show, Eq, Ord) + +newtype UnitId = UnitId {unUnitId :: String} deriving (Show, Eq, Ord) data TrackedMethod (m :: LSP.Method from 'LSP.Request) where TrackedSingleMethodFromClient :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) . LSP.SMethod m + -> LSP.FromClientMessage -- | Store the whole message for re-transmission on subIDE restart + -> PackageHome -- | Store the recipient subIDE for this message -> TrackedMethod m TrackedSingleMethodFromServer :: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request) . LSP.SMethod m - -> FilePath -- Also store the IDE that sent the request + -> Maybe PackageHome -- | Store the IDE that sent the request (or don't, for requests sent by the coordinator) -> TrackedMethod m TrackedAllMethod :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). { tamMethod :: LSP.SMethod m -- ^ The method of the initial request , tamLspId :: LSP.LspId m + , tamClientMessage :: LSP.FromClientMessage + -- ^ Store the whole message for re-transmission on subIDE restart , tamCombiner :: ResponseCombiner m -- ^ How to combine the results from each IDE - , tamRemainingResponseIDERoots :: [FilePath] + , tamRemainingResponsePackageHomes :: [PackageHome] -- ^ The IDES that have not yet replied to this message - , tamResponses :: [(FilePath, Either LSP.ResponseError (LSP.ResponseResult m))] + , tamResponses :: [(PackageHome, Either LSP.ResponseError (LSP.ResponseResult m))] } -> TrackedMethod m tmMethod :: forall (from :: LSP.From) (m :: LSP.Method from 'LSP.Request) . TrackedMethod m -> LSP.SMethod m -tmMethod (TrackedSingleMethodFromClient m) = m +tmMethod (TrackedSingleMethodFromClient m _ _) = m tmMethod (TrackedSingleMethodFromServer m _) = m tmMethod (TrackedAllMethod {tamMethod}) = tamMethod +tmClientMessage + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . TrackedMethod m + -> LSP.FromClientMessage +tmClientMessage (TrackedSingleMethodFromClient _ msg _) = msg +tmClientMessage (TrackedAllMethod {tamClientMessage}) = tamClientMessage + type MethodTracker (from :: LSP.From) = IM.IxMap @(LSP.Method from 'LSP.Request) LSP.LspId TrackedMethod type MethodTrackerVar (from :: LSP.From) = TVar (MethodTracker from) -data SubIDE = SubIDE +data SubIDEInstance = SubIDEInstance { ideInhandleAsync :: Async () , ideInHandle :: Handle , ideInHandleChannel :: TChan BSL.ByteString + , ideOutHandle :: Handle , ideOutHandleAsync :: Async () -- ^ For sending messages to that SubIDE - , ideProcess :: Process Handle Handle () - , ideHomeDirectory :: FilePath + , ideErrHandle :: Handle + , ideErrText :: TVar T.Text + , ideErrTextAsync :: Async () + , ideProcess :: Process Handle Handle Handle + , ideHome :: PackageHome , ideMessageIdPrefix :: T.Text -- ^ Some unique string used to prefix message ids created by the SubIDE, to avoid collisions with other SubIDEs -- We use the stringified process ID - , ideActive :: Bool - , ideUnitId :: String + -- TODO[SW]: This isn't strictly safe since this data exists for a short time after subIDE shutdown, duplicates could be created. + , ideUnitId :: UnitId -- ^ Unit ID of the package this SubIDE handles -- Of the form "daml-script-0.0.1" } +instance Eq SubIDEInstance where + -- ideMessageIdPrefix is derived from process id, so this equality is of the process. + (==) = (==) `on` ideMessageIdPrefix + +instance Ord SubIDEInstance where + -- ideMessageIdPrefix is derived from process id, so this ordering is of the process. + compare = compare `on` ideMessageIdPrefix + +-- We store an optional main ide, the currently closing ides (kept only so they can reply to their shutdowns), and open files +-- open files must outlive the main subide so we can re-send the TextDocumentDidOpen messages on new ide startup +data SubIDEData = SubIDEData + { ideDataHome :: PackageHome + , ideDataMain :: Maybe SubIDEInstance + , ideDataClosing :: Set.Set SubIDEInstance + , ideDataOpenFiles :: Set.Set DamlFile + , ideDataFailTimes :: [UTCTime] + , ideDataDisabled :: Bool + , ideDataLastError :: Maybe String + } + +defaultSubIDEData :: PackageHome -> SubIDEData +defaultSubIDEData home = SubIDEData home Nothing Set.empty Set.empty [] False Nothing + +lookupSubIde :: PackageHome -> SubIDEs -> SubIDEData +lookupSubIde home ides = fromMaybe (defaultSubIDEData home) $ Map.lookup home ides + +ideShouldDisableTimeout :: NominalDiffTime +ideShouldDisableTimeout = 5 + +ideShouldDisable :: SubIDEData -> Bool +ideShouldDisable (ideDataFailTimes -> (t1:t2:_)) = t1 `diffUTCTime` t2 < ideShouldDisableTimeout +ideShouldDisable _ = False + -- SubIDEs placed in a TMVar. The emptyness representents a modification lock. -- The lock unsures the following properties: -- If multiple messages are sent to a new IDE at the same time, the first will create and hold a lock, while the rest wait on that lock (avoid multiple create) -- We never attempt to send messages on a stale IDE. If we ever read SubIDEsVar with the intent to send a message on a SubIDE, we must hold the so a shutdown -- cannot be sent on that IDE until we are done. This ensures that when a shutdown does occur, it is impossible for non-shutdown messages to be added to the -- queue after the shutdown. -type SubIDEs = Map.Map FilePath SubIDE +type SubIDEs = Map.Map PackageHome SubIDEData type SubIDEsVar = TMVar SubIDEs -onlyActiveSubIdes :: SubIDEs -> SubIDEs -onlyActiveSubIdes = Map.filter ideActive +-- Helper functions for holding the subIDEs var +withIDEsAtomic :: MultiIdeState -> (SubIDEs -> STM (SubIDEs, a)) -> IO a +withIDEsAtomic miState f = atomically $ do + ides <- takeTMVar $ subIDEsVar miState + (ides', res) <- f ides + putTMVar (subIDEsVar miState) ides' + pure res + +holdingIDEsAtomic :: MultiIdeState -> (SubIDEs -> STM a) -> IO a +holdingIDEsAtomic miState f = withIDEsAtomic miState $ \ides -> (ides,) <$> f ides + +withIDEs :: MultiIdeState -> (SubIDEs -> IO (SubIDEs, a)) -> IO a +withIDEs miState f = do + ides <- atomically $ takeTMVar $ subIDEsVar miState + (ides', res) <- f ides + atomically $ putTMVar (subIDEsVar miState) ides' + pure res + +holdingIDEs :: MultiIdeState -> (SubIDEs -> IO a) -> IO a +holdingIDEs miState f = withIDEs miState $ \ides -> (ides,) <$> f ides + +withIDEs_ :: MultiIdeState -> (SubIDEs -> IO SubIDEs) -> IO () +withIDEs_ miState f = void $ withIDEs miState $ fmap (, ()) . f -- Stores the initialize messages sent by the client to be forwarded to SubIDEs when they are created. type InitParams = LSP.InitializeParams type InitParamsVar = MVar InitParams --- Maps a packages unit id to its source file path, for all packages listed in a multi-package.yaml -type MultiPackageYamlMapping = Map.Map String FilePath +-- Maps a packages unit id to its source location, using PackageOnDisk for all packages in multi-package.yaml +-- and PackageInDar for all known dars (currently extracted from data-dependencies) +data PackageSourceLocation = PackageOnDisk PackageHome | PackageInDar DarFile deriving Show +type MultiPackageYamlMapping = Map.Map UnitId PackageSourceLocation +type MultiPackageYamlMappingVar = TMVar MultiPackageYamlMapping + +-- Maps a dar path to the list of packages that directly depend on it +type DarDependentPackages = Map.Map DarFile (Set.Set PackageHome) +type DarDependentPackagesVar = TMVar DarDependentPackages + +-- "Cache" for the home path of files/directories +-- Cleared on daml.yaml modification and file deletion +type SourceFileHomes = Map.Map FilePath PackageHome +type SourceFileHomesVar = TMVar SourceFileHomes data MultiIdeState = MultiIdeState { fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient @@ -103,17 +202,38 @@ data MultiIdeState = MultiIdeState , subIDEsVar :: SubIDEsVar , initParamsVar :: InitParamsVar , toClientChan :: TChan BSL.ByteString - , multiPackageMapping :: MultiPackageYamlMapping - , debugPrint :: String -> IO () + , multiPackageMappingVar :: MultiPackageYamlMappingVar + , darDependentPackagesVar :: DarDependentPackagesVar + , logger :: Logger.Handle IO + , multiPackageHome :: FilePath + , defaultPackagePath :: PackageHome + , sourceFileHomesVar :: SourceFileHomesVar + , subIdeArgs :: [String] } -newMultiIdeState :: MultiPackageYamlMapping -> (String -> IO ()) -> IO MultiIdeState -newMultiIdeState multiPackageMapping debugPrint = do +logError :: MultiIdeState -> String -> IO () +logError miState msg = Logger.logError (logger miState) (T.pack msg) + +logWarning :: MultiIdeState -> String -> IO () +logWarning miState msg = Logger.logWarning (logger miState) (T.pack msg) + +logInfo :: MultiIdeState -> String -> IO () +logInfo miState msg = Logger.logInfo (logger miState) (T.pack msg) + +logDebug :: MultiIdeState -> String -> IO () +logDebug miState msg = Logger.logDebug (logger miState) (T.pack msg) + +newMultiIdeState :: FilePath -> PackageHome -> Logger.Priority -> [String] -> IO MultiIdeState +newMultiIdeState multiPackageHome defaultPackagePath logThreshold subIdeArgs = do (fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient) <- newTVarIO IM.emptyIxMap (fromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer) <- newTVarIO IM.emptyIxMap subIDEsVar <- newTMVarIO @SubIDEs mempty initParamsVar <- newEmptyMVar @InitParams toClientChan <- atomically newTChan + multiPackageMappingVar <- newTMVarIO @MultiPackageYamlMapping mempty + darDependentPackagesVar <- newTMVarIO @DarDependentPackages mempty + sourceFileHomesVar <- newTMVarIO @SourceFileHomes mempty + logger <- Logger.newStderrLogger logThreshold "Multi-IDE" pure MultiIdeState {..} -- Forwarding @@ -165,7 +285,7 @@ data Forwarding (m :: LSP.Method 'LSP.FromClient t) where . LSP.NotificationMessage m -> ForwardingBehaviour m -> Forwarding m - ExplicitHandler + ExplicitHandler :: ( (LSP.FromServerMessage -> IO ()) -> (FilePath -> LSP.FromClientMessage -> IO ()) -> IO () @@ -173,4 +293,9 @@ data Forwarding (m :: LSP.Method 'LSP.FromClient t) where -> Forwarding (m :: LSP.Method 'LSP.FromClient t) type ResponseCombiner (m :: LSP.Method 'LSP.FromClient 'LSP.Request) = - [(FilePath, Either LSP.ResponseError (LSP.ResponseResult m))] -> Either LSP.ResponseError (LSP.ResponseResult m) + [(PackageHome, Either LSP.ResponseError (LSP.ResponseResult m))] -> Either LSP.ResponseError (LSP.ResponseResult m) + +data SMethodWithSender (m :: LSP.Method 'LSP.FromServer t) = SMethodWithSender + { smsMethod :: LSP.SMethod m + , smsSender :: Maybe PackageHome + } diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs index 057977070f51..5fa5a38d1081 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs @@ -15,43 +15,48 @@ module DA.Cli.Damlc.Command.MultiIde.Util ( import Control.Concurrent.MVar import Control.Concurrent.STM.TMVar -import Control.Exception (handle) +import Control.Exception (SomeException, handle, try) +import Control.Lens ((^.)) +import Control.Monad (void) import Control.Monad.STM -import DA.Daml.Project.Config (readProjectConfig, queryProjectConfigRequired) -import DA.Daml.Project.Types (ConfigError, ProjectPath (..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Daml.Project.Config (readProjectConfig, queryProjectConfig, queryProjectConfigRequired) +import DA.Daml.Project.Consts (projectConfigName) +import DA.Daml.Project.Types (ConfigError) +import Data.Aeson (Value (Null)) +import Data.Bifunctor (first) +import Data.List.Extra (lower, replace) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP import qualified Language.LSP.Types.Capabilities as LSP -import System.Directory (doesDirectoryExist, listDirectory) -import System.FilePath (takeDirectory) -import System.IO.Extra -import System.IO.Unsafe (unsafePerformIO) - --- Stop mangling my prints! >:( -{-# ANN printLock ("HLint: ignore Avoid restricted function" :: String) #-} -{-# NOINLINE printLock #-} -printLock :: MVar () -printLock = unsafePerformIO $ newMVar () - -makeDebugPrint :: Bool -> String -> IO () -makeDebugPrint True msg = withMVar printLock $ \_ -> do - hPutStrLn stderr msg - hFlush stderr -makeDebugPrint False _ = pure () - -infoPrint :: String -> IO () -infoPrint = makeDebugPrint True - -warnPrint :: String -> IO () -warnPrint msg = infoPrint $ "Warning: " <> msg +import System.Directory (doesDirectoryExist, listDirectory, withCurrentDirectory, canonicalizePath) +import qualified System.FilePath as NativeFilePath +import System.FilePath.Posix (joinDrive, takeDirectory, takeExtension) +import System.IO (Handle, hClose, hFlush) er :: Show x => String -> Either x a -> a er _msg (Right a) = a er msg (Left e) = error $ msg <> ": " <> show e +makeIOBlocker :: IO (IO a -> IO a, IO ()) +makeIOBlocker = do + sendBlocker <- newEmptyMVar @() + let unblock = putMVar sendBlocker () + onceUnblocked = (readMVar sendBlocker >>) + pure (onceUnblocked, unblock) + modifyTMVar :: TMVar a -> (a -> a) -> STM () -modifyTMVar var f = do +modifyTMVar var f = modifyTMVarM var (pure . f) + +modifyTMVarM :: TMVar a -> (a -> STM a) -> STM () +modifyTMVarM var f = do x <- takeTMVar var - putTMVar var (f x) + x' <- f x + putTMVar var x' -- Taken directly from the Initialize response initializeResult :: LSP.InitializeResult @@ -149,32 +154,146 @@ initializeResult = LSP.InitializeResult true = Just (LSP.InL True) false = Just (LSP.InL False) +initializeRequest :: InitParams -> SubIDEInstance -> LSP.FromClientMessage +initializeRequest initParams ide = LSP.FromClientMess LSP.SInitialize LSP.RequestMessage + { _id = LSP.IdString $ ideMessageIdPrefix ide <> "-init" + , _method = LSP.SInitialize + , _params = initParams + { LSP._rootPath = Just $ T.pack $ unPackageHome $ ideHome ide + , LSP._rootUri = Just $ LSP.filePathToUri $ unPackageHome $ ideHome ide + } + , _jsonrpc = "2.0" + } + +openFileNotification :: DamlFile -> T.Text -> LSP.FromClientMessage +openFileNotification path content = LSP.FromClientMess LSP.STextDocumentDidOpen LSP.NotificationMessage + { _method = LSP.STextDocumentDidOpen + , _params = LSP.DidOpenTextDocumentParams + { _textDocument = LSP.TextDocumentItem + { _uri = LSP.filePathToUri $ unDamlFile path + , _languageId = "daml" + , _version = 1 + , _text = content + } + } + , _jsonrpc = "2.0" + } + +registerFileWatchersMessage :: LSP.RequestMessage 'LSP.ClientRegisterCapability +registerFileWatchersMessage = + LSP.RequestMessage "2.0" (LSP.IdString "MultiIdeWatchedFiles") LSP.SClientRegisterCapability $ LSP.RegistrationParams $ LSP.List + [ LSP.SomeRegistration $ LSP.Registration "MultiIdeWatchedFiles" LSP.SWorkspaceDidChangeWatchedFiles $ LSP.DidChangeWatchedFilesRegistrationOptions $ LSP.List + [ LSP.FileSystemWatcher "**/multi-package.yaml" Nothing + , LSP.FileSystemWatcher "**/daml.yaml" Nothing + , LSP.FileSystemWatcher "**/*.dar" Nothing + , LSP.FileSystemWatcher "**/*.daml" Nothing + ] + ] + castLspId :: LSP.LspId m -> LSP.LspId m' castLspId (LSP.IdString s) = LSP.IdString s castLspId (LSP.IdInt i) = LSP.IdInt i -- Given a file path, move up directory until we find a daml.yaml and give its path (if it exists) -findHome :: FilePath -> IO (Maybe FilePath) +findHome :: FilePath -> IO (Maybe PackageHome) findHome path = do exists <- doesDirectoryExist path if exists then aux path else aux (takeDirectory path) where - aux :: FilePath -> IO (Maybe FilePath) + aux :: FilePath -> IO (Maybe PackageHome) aux path = do - hasDamlYaml <- elem "daml.yaml" <$> listDirectory path + hasDamlYaml <- elem projectConfigName <$> listDirectory path if hasDamlYaml - then pure $ Just path + then pure $ Just $ PackageHome path else do let newPath = takeDirectory path if path == newPath then pure Nothing else aux newPath -unitIdFromDamlYaml :: FilePath -> IO (Either ConfigError String) -unitIdFromDamlYaml path = do - handle (\(e :: ConfigError) -> return $ Left e) $ do - project <- readProjectConfig $ ProjectPath path - pure $ do - name <- queryProjectConfigRequired ["name"] project - version <- queryProjectConfigRequired ["version"] project - pure $ name <> "-" <> version +unitIdAndDepsFromDamlYaml :: PackageHome -> IO (Either ConfigError (UnitId, [DarFile])) +unitIdAndDepsFromDamlYaml path = do + handle (\(e :: ConfigError) -> return $ Left e) $ runExceptT $ do + project <- lift $ readProjectConfig $ toProjectPath path + dataDeps <- except $ fromMaybe [] <$> queryProjectConfig ["data-dependencies"] project + directDeps <- except $ fromMaybe [] <$> queryProjectConfig ["dependencies"] project + let directDarDeps = filter (\dep -> takeExtension dep == ".dar") directDeps + canonDeps <- lift $ withCurrentDirectory (unPackageHome path) $ traverse canonicalizePath $ dataDeps <> directDarDeps + name <- except $ queryProjectConfigRequired ["name"] project + version <- except $ queryProjectConfigRequired ["version"] project + pure (UnitId $ name <> "-" <> version, DarFile . toPosixFilePath <$> canonDeps) + +-- LSP requires all requests are replied to. When we don't have a working IDE (say the daml.yaml is malformed), we need to reply +-- We don't want to reply with LSP errors, as there will be too many. Instead, we show our error in diagnostics, and send empty replies +noIDEReply :: LSP.FromClientMessage -> Maybe LSP.FromServerMessage +noIDEReply (LSP.FromClientMess method params) = + case (method, params) of + (LSP.STextDocumentWillSaveWaitUntil, _) -> makeRes params $ LSP.List [] + (LSP.STextDocumentCompletion, _) -> makeRes params $ LSP.InL $ LSP.List [] + (LSP.STextDocumentHover, _) -> makeRes params Nothing + (LSP.STextDocumentSignatureHelp, _) -> makeRes params $ LSP.SignatureHelp (LSP.List []) Nothing Nothing + (LSP.STextDocumentDeclaration, _) -> makeRes params $ LSP.InR $ LSP.InL $ LSP.List [] + (LSP.STextDocumentDefinition, _) -> makeRes params $ LSP.InR $ LSP.InL $ LSP.List [] + (LSP.STextDocumentDocumentSymbol, _) -> makeRes params $ LSP.InL $ LSP.List [] + (LSP.STextDocumentCodeAction, _) -> makeRes params $ LSP.List [] + (LSP.STextDocumentCodeLens, _) -> makeRes params $ LSP.List [] + (LSP.STextDocumentDocumentLink, _) -> makeRes params $ LSP.List [] + (LSP.STextDocumentColorPresentation, _) -> makeRes params $ LSP.List [] + (LSP.STextDocumentOnTypeFormatting, _) -> makeRes params $ LSP.List [] + (LSP.SWorkspaceExecuteCommand, _) -> makeRes params Null + (LSP.SCustomMethod "daml/tryGetDefinition", LSP.ReqMess params) -> noDefinitionRes params + (LSP.SCustomMethod "daml/gotoDefinitionByName", LSP.ReqMess params) -> noDefinitionRes params + _ -> Nothing + where + makeRes :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.RequestMessage m -> LSP.ResponseResult m -> Maybe LSP.FromServerMessage + makeRes params result = Just $ LSP.FromServerRsp (params ^. LSP.method) $ LSP.ResponseMessage "2.0" (Just $ params ^. LSP.id) (Right result) + noDefinitionRes :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.RequestMessage m -> Maybe LSP.FromServerMessage + noDefinitionRes params = Just $ LSP.FromServerRsp LSP.STextDocumentDefinition $ LSP.ResponseMessage "2.0" (Just $ castLspId $ params ^. LSP.id) $ + Right $ LSP.InR $ LSP.InL $ LSP.List [] +noIDEReply _ = Nothing + +-- | Publishes an error diagnostic for a file containing the given message +fullFileDiagnostic :: String -> FilePath -> LSP.FromServerMessage +fullFileDiagnostic message path = LSP.FromServerMess LSP.STextDocumentPublishDiagnostics $ LSP.NotificationMessage "2.0" LSP.STextDocumentPublishDiagnostics + $ LSP.PublishDiagnosticsParams (LSP.filePathToUri path) Nothing $ LSP.List [LSP.Diagnostic + { _range = LSP.Range (LSP.Position 0 0) (LSP.Position 0 1000) + , _severity = Just LSP.DsError + , _code = Nothing + , _source = Just "Daml Multi-IDE" + , _message = T.pack message + , _tags = Nothing + , _relatedInformation = Nothing + }] + +-- | Clears diagnostics for a given file +clearDiagnostics :: FilePath -> LSP.FromServerMessage +clearDiagnostics path = LSP.FromServerMess LSP.STextDocumentPublishDiagnostics $ LSP.NotificationMessage "2.0" LSP.STextDocumentPublishDiagnostics + $ LSP.PublishDiagnosticsParams (LSP.filePathToUri path) Nothing $ LSP.List [] + +fromClientRequestLspId :: LSP.FromClientMessage -> Maybe LSP.SomeLspId +fromClientRequestLspId (LSP.FromClientMess method params) = + case (LSP.splitClientMethod method, params) of + (LSP.IsClientReq, _) -> Just $ LSP.SomeLspId $ params ^. LSP.id + (LSP.IsClientEither, LSP.ReqMess params) -> Just $ LSP.SomeLspId $ params ^. LSP.id + _ -> Nothing +fromClientRequestLspId _ = Nothing + +fromClientRequestMethod :: LSP.FromClientMessage -> LSP.SomeMethod +fromClientRequestMethod (LSP.FromClientMess method _) = LSP.SomeMethod method +fromClientRequestMethod (LSP.FromClientRsp method _) = LSP.SomeMethod method + +-- Windows can throw errors like `resource vanished` on dead handles, instead of being a no-op +-- In those cases, we're already convinced the handle is closed, so we simply "try" to close handles +-- and accept whatever happens +hTryClose :: Handle -> IO () +hTryClose handle = void $ try @SomeException $ hClose handle + +-- hFlush will error if the handle closes while its blocked on flushing +-- We don't care what happens in this event, so we ignore the error as with tryClose +hTryFlush :: Handle -> IO () +hTryFlush handle = void $ try @SomeException $ hFlush handle + +-- Changes backslashes to forward slashes, lowercases the drive +-- Need native filepath for splitDrive, as Posix version just takes first n `/`s +toPosixFilePath :: FilePath -> FilePath +toPosixFilePath = uncurry joinDrive . first lower . NativeFilePath.splitDrive . replace "\\" "/" diff --git a/sdk/compiler/damlc/lib/DA/Cli/Options.hs b/sdk/compiler/damlc/lib/DA/Cli/Options.hs index 93beecd92569..4a119f4b9cf8 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Options.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Options.hs @@ -154,10 +154,6 @@ newtype InitPkgDb = InitPkgDb Bool initPkgDbOpt :: Parser InitPkgDb initPkgDbOpt = InitPkgDb <$> flagYesNoAuto "init-package-db" True "Initialize package database" idm -newtype MultiIdeVerbose = MultiIdeVerbose {getMultiIdeVerbose :: Bool} -multiIdeVerboseOpt :: Parser MultiIdeVerbose -multiIdeVerboseOpt = MultiIdeVerbose <$> flagYesNoAuto "verbose" False "Enable verbose logging for the Multi-IDE" idm - newtype EnableMultiPackage = EnableMultiPackage {getEnableMultiPackage :: Bool} enableMultiPackageOpt :: Parser EnableMultiPackage enableMultiPackageOpt = EnableMultiPackage <$> flagYesNoAuto "enable-multi-package" True "Enable/disable multi-package.yaml support (enabled by default)" idm