diff --git a/sdk/bazel-haskell-deps.bzl b/sdk/bazel-haskell-deps.bzl index 8de97cc5a1ec..1c16f16d595b 100644 --- a/sdk/bazel-haskell-deps.bzl +++ b/sdk/bazel-haskell-deps.bzl @@ -18,8 +18,8 @@ load("@dadew//:dadew.bzl", "dadew_tool_home") load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot") load("//bazel_tools/ghc-lib:repositories.bzl", "ghc_lib_and_dependencies") -GHCIDE_REV = "223e571d3cac214d131b85330bf09a1762e88671" -GHCIDE_SHA256 = "5604a0e30f6e0a2ca8b2d8f9883698d4c97efdcf7d84d27539d433a49d40cf74" +GHCIDE_REV = "96d92b9b5b5abea5e1d3df2ae06e26094d986139" +GHCIDE_SHA256 = "a1a4b9157f81491d9dc580b638fec61e42c6c1b44e30d7ceee8c38a57e308ab6" GHCIDE_LOCAL_PATH = None JS_JQUERY_VERSION = "3.3.1" JS_DGTABLE_VERSION = "0.5.2" @@ -55,6 +55,7 @@ haskell_cabal_library( patch_args = ["-p1"], patches = [ "@com_github_digital_asset_daml//bazel_tools:lsp-types-normalisation.patch", + "@com_github_digital_asset_daml//bazel_tools:lsp-types-expose-other-modules.patch", ], sha256 = LSP_TYPES_SHA256, strip_prefix = "lsp-types-{}".format(LSP_TYPES_VERSION), @@ -463,6 +464,7 @@ exports_files(["stack.exe"], visibility = ["//visibility:public"]) "ansi-wl-pprint", "array", "async", + "attoparsec", "base", "base16-bytestring", "base64", @@ -549,6 +551,7 @@ exports_files(["stack.exe"], visibility = ["//visibility:public"]) "semigroupoids", "semver", "silently", + "some", "sorted-list", "split", "stache", diff --git a/sdk/bazel_tools/lsp-types-expose-other-modules.patch b/sdk/bazel_tools/lsp-types-expose-other-modules.patch new file mode 100644 index 000000000000..eafabbfcc91f --- /dev/null +++ b/sdk/bazel_tools/lsp-types-expose-other-modules.patch @@ -0,0 +1,20 @@ +diff --git a/lsp-types.cabal b/lsp-types.cabal +index 1af6907..1443cc0 100644 +--- a/lsp-types.cabal ++++ b/lsp-types.cabal +@@ -21,6 +21,7 @@ library + , Language.LSP.Types.Capabilities + , Language.LSP.Types.Lens + , Language.LSP.Types.SMethodMap ++ , Language.LSP.Types.Utils + , Language.LSP.VFS + , Data.IxMap + other-modules: Language.LSP.Types.CallHierarchy +@@ -63,7 +64,6 @@ library + , Language.LSP.Types.TextDocument + , Language.LSP.Types.TypeDefinition + , Language.LSP.Types.Uri +- , Language.LSP.Types.Utils + , Language.LSP.Types.Window + , Language.LSP.Types.WatchedFiles + , Language.LSP.Types.WorkspaceEdit diff --git a/sdk/compiler/daml-extension/package.json b/sdk/compiler/daml-extension/package.json index 0f22c061cb9c..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", @@ -111,6 +113,11 @@ "type": "string", "default": "", "description": "Extra arguments passed to `damlc ide`. This can be used to enable additional warnings via `--ghc-option -W`" + }, + "daml.multiPackageIdeSupport": { + "type": "boolean", + "default": false, + "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 732092f586b1..f5ea76aa0361 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,57 +40,106 @@ 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, - ), + 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, + ), + ); + let sdkInstallState: SdkInstallState = {}; + damlLanguageClient.onNotification(DamlSdkInstallProgress.type, params => + handleDamlSdkInstallProgress(sdkInstallState, params), + ); + }); - 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), @@ -232,6 +282,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, @@ -243,7 +329,6 @@ export function createLanguageClient( }; let command: string; - let args: string[] = ["ide", "--"]; try { command = which.sync("daml"); @@ -259,32 +344,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"); - } - 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", { @@ -295,14 +357,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 @@ -359,6 +423,84 @@ namespace DamlKeepAliveRequest { // Custom notifications +interface DamlSdkInstallProgressNotification { + sdkVersion: string; + kind: "begin" | "report" | "end"; + progress: number; +} + +namespace DamlSdkInstallProgress { + export let type = new NotificationType( + "daml/sdkInstallProgress", + ); +} + +interface DamlSdkInstallCancelNotification { + sdkVersion: string; +} + +namespace DamlSdkInstallCancel { + export let type = new NotificationType( + "daml/sdkInstallCancel", + ); +} + +type Progress = vscode.Progress<{ increment: number }>; +type SdkInstallState = { + [sdkVersion: string]: { + progress: Progress; + resolve: (_: void) => void; + reported: number; + }; +}; + +// Handle the SdkInstall work done tokens separately, as we want them to popup as a notification, but VSCode LSPClient doesn't give us a way to do this +function handleDamlSdkInstallProgress( + sdkInstallState: SdkInstallState, + message: DamlSdkInstallProgressNotification, +): void { + switch (message.kind) { + case "begin": + vscode.window.withProgress( + { + location: vscode.ProgressLocation.Notification, + cancellable: true, + title: "Installing Daml SDK " + message.sdkVersion, + }, + async ( + progress: Progress, + cancellationToken: vscode.CancellationToken, + ) => { + cancellationToken.onCancellationRequested(() => { + delete sdkInstallState[message.sdkVersion]; + damlLanguageClient.sendNotification(DamlSdkInstallCancel.type, { + sdkVersion: message.sdkVersion, + }); + }); + return new Promise((resolve, _) => { + sdkInstallState[message.sdkVersion] = { + progress, + resolve, + reported: 0, + }; + }); + }, + ); + break; + case "report": + let progressData = sdkInstallState[message.sdkVersion]; + if (!progressData) return; + let diff = Math.max(0, message.progress - progressData.reported); + progressData.progress.report({ increment: diff }); + progressData.reported += diff; + break; + case "end": + sdkInstallState[message.sdkVersion]?.resolve(); + delete sdkInstallState[message.sdkVersion]; + break; + } +} + interface VirtualResourceChangedParams { /** The virtual resource uri */ uri: string; diff --git a/sdk/compiler/damlc/BUILD.bazel b/sdk/compiler/damlc/BUILD.bazel index c2a0fc5dd8b5..32027e8b8543 100644 --- a/sdk/compiler/damlc/BUILD.bazel +++ b/sdk/compiler/damlc/BUILD.bazel @@ -170,6 +170,8 @@ da_haskell_library( hackage_deps = [ "aeson", "aeson-pretty", + "async", + "attoparsec", "ansi-wl-pprint", "ansi-terminal", "base", @@ -196,20 +198,25 @@ da_haskell_library( "memory", "mtl", "network", + "network-uri", "optparse-applicative", "prettyprinter", "process", + "typed-process", "proto3-suite", "regex-tdfa", "safe", "safe-exceptions", "shake", + "some", "split", + "stm", "tasty", "tasty-ant-xml", "tasty-hunit", "temporary", "text", + "time", "transformers", "uniplate", "unordered-containers", diff --git a/sdk/compiler/damlc/daml-ide/BUILD.bazel b/sdk/compiler/damlc/daml-ide/BUILD.bazel index 3e9b8e580f25..4b0895c7a339 100644 --- a/sdk/compiler/damlc/daml-ide/BUILD.bazel +++ b/sdk/compiler/damlc/daml-ide/BUILD.bazel @@ -17,7 +17,11 @@ da_haskell_library( "containers", "data-default", "extra", + "filepath", + "ghc-lib", + "ghc-lib-parser", "ghcide", + "lens", "lsp", "lsp-types", "network-uri", @@ -25,9 +29,11 @@ da_haskell_library( "rope-utf16-splay", "safe", "safe-exceptions", + "shake", "stm", "tagged", "text", + "transformers", "uri-encode", "unordered-containers", ], @@ -35,9 +41,12 @@ da_haskell_library( visibility = ["//visibility:public"], deps = [ "//compiler/daml-lf-ast", + "//compiler/damlc/daml-compiler", "//compiler/damlc/daml-ide-core", "//compiler/damlc/daml-lf-util", + "//compiler/damlc/daml-package-config", "//compiler/damlc/daml-rule-types", + "//daml-assistant:daml-project-config", "//libs-haskell/da-hs-base", ], ) diff --git a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs index 5ea35a1f492d..39a0a465d815 100644 --- a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs +++ b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs @@ -15,6 +15,7 @@ import qualified Data.Aeson as Aeson import Data.Default import qualified DA.Daml.LanguageServer.CodeLens as VirtualResource +import qualified DA.Daml.LanguageServer.SplitGotoDefinition as SplitGotoDefinition import Development.IDE.Types.Logger import qualified Data.HashSet as HS @@ -43,7 +44,7 @@ setHandlersKeepAlive :: Plugin c setHandlersKeepAlive = Plugin { pluginCommands = mempty , pluginRules = mempty - , pluginHandlers = pluginHandler (SCustomMethod "daml/keepAlive") $ \_ _ -> pure (Right Aeson.Null) + , pluginHandlers = pluginHandler (SCustomMethod "daml/keepAlive") $ \_ _ -> pure (Right Aeson.Null) , pluginNotificationHandlers = mempty } @@ -87,7 +88,7 @@ runLanguageServer -> (LSP.LanguageContextEnv c -> VFSHandle -> Maybe FilePath -> IO IdeState) -> IO () runLanguageServer lgr plugins conf getIdeState = SessionTelemetry.withPlugin lgr $ \sessionHandlerPlugin -> do - let allPlugins = plugins <> setHandlersKeepAlive <> setHandlersVirtualResource <> VirtualResource.plugin <> sessionHandlerPlugin + let allPlugins = plugins <> setHandlersKeepAlive <> setHandlersVirtualResource <> VirtualResource.plugin <> sessionHandlerPlugin <> SplitGotoDefinition.plugin let onConfigurationChange c _ = Right c let options = def { LSP.executeCommandCommands = Just (commandIds allPlugins) } LS.runLanguageServer options conf onConfigurationChange allPlugins getIdeState diff --git a/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs new file mode 100644 index 000000000000..a1e83e0ae51d --- /dev/null +++ b/sdk/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer/SplitGotoDefinition.hs @@ -0,0 +1,239 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Custom methods for interupting the usual goto definition flow for multi-ide deferring +module DA.Daml.LanguageServer.SplitGotoDefinition + ( GotoDefinitionByNameParams (..) + , GotoDefinitionByNameResult + , TryGetDefinitionName (..) + , TryGetDefinitionNameSpace (..) + , TryGetDefinitionParams (..) + , TryGetDefinitionResult (..) + , fromTryGetDefinitionNameSpace + , plugin + , toTryGetDefinitionNameSpace + ) where + +import Control.Lens ((^.)) +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE, except) +import DA.Daml.Compiler.Dar (getDamlFiles) +import DA.Daml.Package.Config (PackageConfigFields (pSrc), parseProjectConfig) +import DA.Daml.Project.Config (readProjectConfig) +import DA.Daml.Project.Types (ProjectPath (..)) +import qualified Data.Aeson as Aeson +import Data.Aeson.TH +import qualified Data.Aeson.Types as Aeson +import Data.Bifunctor (first) +import Data.List (find, isSuffixOf, sortOn) +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import Development.IDE.Core.Rules.Daml +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service.Daml +import Development.IDE.Core.Shake (IdeRule, use) +import Development.IDE.GHC.Error (srcSpanToLocation) +import Development.IDE.Plugin +import Development.IDE.Spans.Type (getNameM, spaninfoSource, spansExprs) +import Development.IDE.Types.Location +import Development.Shake (Action) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP +import qualified Language.LSP.Types.Utils as LSP +import System.FilePath (()) +import "ghc-lib" GhcPlugins ( + Module, + isGoodSrcSpan, + moduleName, + moduleNameString, + moduleUnitId, + occNameString, + unitIdString, + ) +import "ghc-lib-parser" Name ( + Name, + NameSpace, + dataName, + isDataConNameSpace, + isExternalName, + isTcClsNameSpace, + isTvNameSpace, + mkOccName, + nameModule_maybe, + nameOccName, + nameSrcSpan, + occNameSpace, + tcClsName, + tvName, + varName, + ) + +data TryGetDefinitionParams = TryGetDefinitionParams + { tgdpTextDocument :: TextDocumentIdentifier + , tgdpPosition :: Position + } + deriving Show +deriveJSON LSP.lspOptions ''TryGetDefinitionParams + +data TryGetDefinitionNameSpace + = VariableName + | DataName + | TypeVariableName + | TypeCnstrOrClassName + deriving Show +deriveJSON LSP.lspOptions ''TryGetDefinitionNameSpace + +fromTryGetDefinitionNameSpace :: TryGetDefinitionNameSpace -> NameSpace +fromTryGetDefinitionNameSpace = \case + VariableName -> varName + DataName -> dataName + TypeVariableName -> tvName + TypeCnstrOrClassName -> tcClsName + +toTryGetDefinitionNameSpace :: NameSpace -> TryGetDefinitionNameSpace +toTryGetDefinitionNameSpace ns = if + | isDataConNameSpace ns -> DataName + | isTcClsNameSpace ns -> TypeCnstrOrClassName + | isTvNameSpace ns -> TypeVariableName + | otherwise -> VariableName + +data TryGetDefinitionName = TryGetDefinitionName + { tgdnModuleName :: String + , tgdnPackageUnitId :: String + , tgdnIdentifierName :: String + , tgdnIdentifierNameSpace :: TryGetDefinitionNameSpace + } + deriving Show +deriveJSON LSP.lspOptions ''TryGetDefinitionName + +data TryGetDefinitionResult = TryGetDefinitionResult + { tgdrLocation :: Location + , tgdrName :: Maybe TryGetDefinitionName + } + deriving Show +deriveJSON LSP.lspOptions ''TryGetDefinitionResult + +data GotoDefinitionByNameParams = GotoDefinitionByNameParams + { gdnpBackupLocation :: Location + , gdnpName :: TryGetDefinitionName + } + deriving Show +deriveJSON LSP.lspOptions ''GotoDefinitionByNameParams + +type GotoDefinitionByNameResult = Location + +{- +2 methods: +tryGotoDefinition :: position -> location + Maybe (name + package) + -- locationsAtPoint but if its an unhelpful name, we provide that too +gotoDefinitionByName :: name -> location + -- try to lookup the name (by its module) in own modules, give back the source + + +flow +call tryGotoDefinition on package of given location + if no (name + package), or we don't have an ide/source for that package, return the location immediately + else + call gotoDefinitionByName on returned package +-} + +plugin :: Plugin c +plugin = Plugin + { pluginCommands = mempty + , pluginRules = mempty + , pluginHandlers = + customMethodHandler "tryGetDefinition" tryGetDefinition + <> customMethodHandler "gotoDefinitionByName" gotoDefinitionByName + , pluginNotificationHandlers = mempty + } + +customMethodHandler + :: forall req res c + . (Aeson.FromJSON req, Aeson.ToJSON res) + => T.Text + -> (IdeState -> req -> LSP.LspM c (Either LSP.ResponseError res)) + -> PluginHandlers c +customMethodHandler name f = pluginHandler (SCustomMethod $ "daml/" <> name) $ \ideState value -> + let (!params :: req) = + either + (\err -> error $ "Failed to parse message of daml/" <> T.unpack name <> ": " <> err) id + $ Aeson.parseEither Aeson.parseJSON value + in fmap Aeson.toJSON <$> f ideState params + +nameSortExternalModule :: Name -> Maybe Module +nameSortExternalModule m | isExternalName m = nameModule_maybe m +nameSortExternalModule _ = Nothing + +-- daml/tryGetDefinition :: TryGetDefinitionParams -> Maybe TryGetDefinitionResult +tryGetDefinition :: IdeState -> TryGetDefinitionParams -> LSP.LspM c (Either ResponseError (Maybe TryGetDefinitionResult)) +tryGetDefinition ideState params = Right <$> + case uriToFilePath' $ tgdpTextDocument params ^. LSP.uri of + Nothing -> pure Nothing + Just (toNormalizedFilePath' -> file) -> + liftIO $ runActionSync ideState $ runMaybeT $ do + (loc, mName) <- MaybeT $ getDefinitionWithName file $ tgdpPosition params + let tgdName = do + name <- mName + m <- nameSortExternalModule name + pure $ TryGetDefinitionName + (moduleNameString $ moduleName m) + (unitIdString $ moduleUnitId m) + (occNameString $ nameOccName name) + (toTryGetDefinitionNameSpace $ occNameSpace $ nameOccName name) + pure $ TryGetDefinitionResult loc tgdName + +replaceChar :: Char -> Char -> String -> String +replaceChar val replacement = fmap (\c -> if c == val then replacement else c) + +-- daml/gotoDefinitionByName :: GotoDefinitionByNameParams -> GotoDefinitionByNameResult +gotoDefinitionByName :: IdeState -> GotoDefinitionByNameParams -> LSP.LspM c (Either ResponseError GotoDefinitionByNameResult) +gotoDefinitionByName ideState params = do + mRoot <- LSP.getRootPath + liftIO $ runActionSync ideState $ exceptTToResult $ do + -- Working out the file by getting the IDE root and pSrc from daml.yaml, getting all the source files for it, then searching for our module + -- We search rather than explicitly building the path to account for pSrc being a daml file, whereby file discovery logic is via dependencies + -- I tried to do this better, by looking up the module name in IDE state, but it seems the IDE doesn't load + -- modules until you open the file, so it doesn't hold any context about "all" modules. + -- (trust me I tried so hard to make this work) + root <- hoistMaybe (Just "Failed to get IDE root") mRoot + projectConfig <- liftIO $ readProjectConfig (ProjectPath root) + config <- except $ first (Just . show) $ parseProjectConfig projectConfig + + srcFiles <- maybeTToExceptT "Failed to get source files" $ getDamlFiles $ root pSrc config + -- Must be sorted shorted to longest, since we always want the shortest path that matches our suffix + -- to avoid accidentally picking Main.A.B.C if we're just looking for A.B.C + -- We also prefix all paths with "/" and search for our suffix starting with "/" + -- This is avoid incorrectly picking MA.B.C if we were looking for A.B.C and it didnt exist + let sortedSrcFiles = sortOn (Prelude.length . fromNormalizedFilePath) srcFiles + moduleSuffix = "/" <> replaceChar '.' '/' (tgdnModuleName $ gdnpName params) <> ".daml" + file <- + hoistMaybe (Just "Failed to find module") $ + find (isSuffixOf moduleSuffix . ("/" <> ) . fromNormalizedFilePath) sortedSrcFiles + + -- It might be better to get the typechecked module and look for the identifier in there? + spans <- useOrThrow "Failed to get span info" GetSpanInfo file + let expectedOccName = mkOccName (fromTryGetDefinitionNameSpace $ tgdnIdentifierNameSpace $ gdnpName params) (tgdnIdentifierName $ gdnpName params) + locations = + [ srcSpanToLocation $ nameSrcSpan name + | Just name <- getNameM . spaninfoSource <$> spansExprs spans + , expectedOccName == nameOccName name && isGoodSrcSpan (nameSrcSpan name) + ] + + hoistMaybe Nothing $ listToMaybe locations + where + -- A Nothing error means no location, a string error means a response error + exceptTToResult :: ExceptT (Maybe String) Action GotoDefinitionByNameResult -> Action (Either ResponseError GotoDefinitionByNameResult) + exceptTToResult t = fmap (either (maybe (Right $ gdnpBackupLocation params) (\msg -> Left $ ResponseError ParseError (T.pack msg) Nothing)) Right) $ runExceptT t + useOrThrow :: IdeRule k v => String -> k -> NormalizedFilePath -> ExceptT (Maybe String) Action v + useOrThrow msg k path = ExceptT $ maybe (Left $ Just msg) Right <$> use k path + hoistMaybe :: Monad m => x -> Maybe a -> ExceptT x m a + hoistMaybe err = maybe (throwE err) pure + maybeTToExceptT :: String -> MaybeT Action a -> ExceptT (Maybe String) Action a + maybeTToExceptT err m = ExceptT $ maybe (Left $ Just err) Right <$> runMaybeT m diff --git a/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs b/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs index 357b3ff1f111..fe3767c7a57d 100644 --- a/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs +++ b/sdk/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs @@ -136,6 +136,7 @@ getDamlGhcSession = do -- | Find the daml.yaml given a starting file or directory. findProjectRoot :: FilePath -> IO (Maybe FilePath) findProjectRoot file = do + -- TODO[SW]: This logic appears to be wrong, doesFileExist (takeDirectory file) will always be false for wellformed paths. isFile <- doesFileExist (takeDirectory file) let dir = if isFile then takeDirectory file else file findM hasProjectConfig (ascendants dir) 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 865acec3fbe2..f4df130bc8fd 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 fcaf6fe18dcf..c7dd332922d2 100644 --- a/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc.hs @@ -3,10 +3,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveAnyClass #-} -- | Main entry-point of the Daml compiler @@ -15,7 +15,8 @@ module DA.Cli.Damlc (main, Command (..), MultiPackageManifestEntry (..), fullPar import qualified "zip-archive" Codec.Archive.Zip as ZipArchive import Control.Exception (bracket, catch, displayException, handle, throwIO, throw) import Control.Exception.Safe (catchIO) -import Control.Monad.Except (forM, forM_, liftIO, unless, void, when) +import Control.Monad (forM, forM_, unless, void, when) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Extra (allM, mapMaybeM, whenM, whenJust) import Control.Monad.Trans.Cont (ContT (..), evalContT) import qualified Crypto.Hash as Hash @@ -38,6 +39,7 @@ import DA.Cli.Options (Debug(..), Style(..), Telemetry(..), cliOptDetailLevel, + cliOptLogLevel, debugOpt, disabledDlintUsageParser, enabledDlintUsageParser, @@ -65,6 +67,7 @@ import DA.Cli.Options (Debug(..), targetFileNameOpt, telemetryOpt) import DA.Cli.Damlc.BuildInfo (buildInfo) +import DA.Cli.Damlc.Command.MultiIde (runMultiIde) import qualified DA.Daml.Dar.Reader as InspectDar import qualified DA.Cli.Damlc.Command.Damldoc as Damldoc import DA.Cli.Damlc.Packaging (createProjectPackageDb, mbErr) @@ -236,6 +239,7 @@ import Options.Applicative ((<|>), execParserPure, flag, flag', + forwardOptions, fullDesc, handleParseResult, headerDoc, @@ -318,9 +322,22 @@ data CommandName = | Test | Repl | GenerateMultiPackageManifest + | MultiIde deriving (Ord, Show, Eq) data Command = Command CommandName (Maybe ProjectOpts) (IO ()) +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 + <$> cliOptLogLevel + <*> many (strArgument mempty) + cmdIde :: SdkVersion.Class.SdkVersioned => Int -> Mod CommandFields Command cmdIde numProcessors = command "ide" $ info (helper <*> cmd) $ @@ -1746,6 +1763,7 @@ options :: SdkVersion.Class.SdkVersioned => Int -> Parser Command options numProcessors = subparser ( cmdIde numProcessors + <> cmdMultiIde numProcessors <> cmdLicense -- cmdPackage can go away once we kill the old assistant. <> cmdPackage numProcessors @@ -1938,6 +1956,7 @@ cmdUseDamlYamlArgs = \case Test -> True Repl -> True GenerateMultiPackageManifest -> False -- Just reads config files + MultiIde -> False withProjectRoot' :: ProjectOpts -> ((FilePath -> IO FilePath) -> IO a) -> IO a withProjectRoot' ProjectOpts{..} act = diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs new file mode 100644 index 000000000000..0c3ef8ac8360 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde.hs @@ -0,0 +1,156 @@ +-- 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 (runMultiIde) where + +import Control.Concurrent.Async (async, cancel, pollSTM) +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TVar +import Control.Exception(SomeException, fromException) +import Control.Monad +import Control.Monad.STM +import qualified Data.ByteString.Lazy.Char8 as BSLC +import DA.Cli.Damlc.Command.MultiIde.Handlers +import DA.Cli.Damlc.Command.MultiIde.PackageData +import DA.Cli.Damlc.Command.MultiIde.Parsing +import DA.Cli.Damlc.Command.MultiIde.SubIdeManagement +import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Cli.Damlc.Command.MultiIde.Util +import qualified DA.Service.Logger as Logger +import Data.Either (lefts) +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, maybeToList) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import qualified SdkVersion.Class +import System.Directory (getCurrentDirectory) +import System.Exit (exitSuccess) +import System.FilePath.Posix (()) +import System.IO.Extra +import System.Process.Typed (ExitCode (..), getExitCodeSTM) + +-- Main loop logic + +createDefaultPackage :: SdkVersion.Class.SdkVersioned => IO (PackageHome, IO ()) +createDefaultPackage = do + (toPosixFilePath -> misDefaultPackagePath, cleanup) <- newTempDir + writeFile (misDefaultPackagePath "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 misDefaultPackagePath, cleanup) + +runMultiIde :: SdkVersion.Class.SdkVersioned => Logger.Priority -> [String] -> IO () +runMultiIde loggingThreshold args = do + homePath <- toPosixFilePath <$> getCurrentDirectory + (misDefaultPackagePath, cleanupDefaultPackage) <- createDefaultPackage + let misSubIdeArgs = if loggingThreshold <= Logger.Debug then "--debug" : args else args + miState <- newMultiIdeState homePath misDefaultPackagePath loggingThreshold misSubIdeArgs subIdeMessageHandler unsafeAddNewSubIdeAndSend + 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 $ onceUnblocked $ forever $ do + msg <- atomically $ readTChan $ misToClientChan miState + logDebug miState $ "Pushing message to client:\n" <> BSLC.unpack msg + putChunk stdout msg + + -- Client -> Coord + clientToCoordThread <- async $ + 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 + 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 <- 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 + , ideDataFailures = + if isCrash && isMainIde + then take 2 $ (currentTime, stderrContent) : ideDataFailures ideData + else ideDataFailures ideData + } + toRestart' = if isCrash && isMainIde then home : toRestart else toRestart + when (isCrash && isMainIde) $ + logWarning miState $ "Proccess failed, stderr content:\n" <> T.unpack 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 $ misSubIdesVar miState + + 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/ClientCommunication.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/ClientCommunication.hs new file mode 100644 index 000000000000..c68a07733868 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/ClientCommunication.hs @@ -0,0 +1,22 @@ +-- 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.ClientCommunication ( + module DA.Cli.Damlc.Command.MultiIde.ClientCommunication +) where + +import Control.Concurrent.STM.TChan +import Control.Monad.STM +import qualified Data.Aeson as Aeson +import DA.Cli.Damlc.Command.MultiIde.Types +import qualified Language.LSP.Types as LSP + +sendClientSTM :: MultiIdeState -> LSP.FromServerMessage -> STM () +sendClientSTM miState = writeTChan (misToClientChan miState) . Aeson.encode + +sendClient :: MultiIdeState -> LSP.FromServerMessage -> IO () +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 (misToClientChan miState) . Aeson.encode 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..d45ae5c319fe --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/DarDependencies.hs @@ -0,0 +1,201 @@ +-- 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 + packageMeta = getPackageMetadata mainPkg + damlYamlContent = unlines $ + [ "sdk-version: " <> sdkVersion manifest + , "name: " <> T.unpack (LF.unPackageName $ LF.packageName packageMeta) + , "version: " <> T.unpack (LF.unPackageVersion $ LF.packageVersion packageMeta) + , "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 + +getPackageMetadata :: LF.Package -> LF.PackageMetadata +getPackageMetadata = fromMaybe (LF.PackageMetadata (LF.PackageName "unknown-package-name") (LF.PackageVersion "1.0.0") Nothing) . LF.packageMetadata + +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 = misMultiPackageHome 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) + pkgMetadata :: LF.PackageMetadata + pkgMetadata = getPackageMetadata 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 (LF.packageName pkgMetadata) (Just $ LF.packageVersion pkgMetadata) [] 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 new file mode 100644 index 000000000000..66c7ed8f81bd --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Forwarding.hs @@ -0,0 +1,190 @@ +-- 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 TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- We generate missing instances for SignatureHelpParams +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module DA.Cli.Damlc.Command.MultiIde.Forwarding ( + getMessageForwardingBehaviour, + filePathFromParamsWithTextDocument, + Forwarding (..), + ForwardingBehaviour (..), + ResponseCombiner, +) where + +import Control.Applicative ((<|>)) +import Control.Lens +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Lens as Aeson +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Development.IDE.Core.Rules.Daml (uriToVirtualResource) +import Development.IDE.Core.RuleTypes.Daml (VirtualResource (..)) +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP +import qualified Network.URI as URI +import DA.Cli.Damlc.Command.MultiIde.Types + +{-# ANN module ("HLint: ignore Avoid restricted flags" :: String) #-} + +-- SignatureHelpParams has no lenses from Language.LSP.Types.Lens +-- We just need this one, so we'll write it ourselves +makeLensesFor [("_textDocument", "signatureHelpParamsTextDocumentLens")] ''LSP.SignatureHelpParams +instance LSP.HasTextDocument LSP.SignatureHelpParams LSP.TextDocumentIdentifier where + textDocument = signatureHelpParamsTextDocumentLens + +pullMonadThroughTuple :: Monad m => (a, m b) -> m (a, b) +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) + . ([(PackageHome, LSP.ResponseResult m)] -> LSP.ResponseResult m) + -> ResponseCombiner m +assumeSuccessCombiner f res = f <$> mapM pullMonadThroughTuple res + +ignore :: Forwarding m +ignore = ExplicitHandler $ \_ _ -> pure () + +showError :: T.Text -> Forwarding m +showError err = ExplicitHandler $ \sendClient _ -> + sendClient $ LSP.FromServerMess LSP.SWindowShowMessage + $ LSP.NotificationMessage "2.0" LSP.SWindowShowMessage + $ LSP.ShowMessageParams LSP.MtError err + +showFatal :: T.Text -> Forwarding m +showFatal err = showError $ "FATAL ERROR:\n" <> err <> "\nPlease report this on the daml forums." + +handleElsewhere :: T.Text -> Forwarding m +handleElsewhere name = showFatal $ "Got unexpected " <> name <> " message in forwarding handler, this message should have been handled elsewhere." + +unsupported :: T.Text -> Forwarding m +unsupported name = showFatal $ "Attempted to call a method that is unsupported by the underlying IDEs: " <> name + +uriFilePathPrism :: Prism' LSP.Uri FilePath +uriFilePathPrism = prism' LSP.filePathToUri LSP.uriToFilePath + +getMessageForwardingBehaviour + :: forall t (m :: LSP.Method 'LSP.FromClient t) + . MultiIdeState + -> LSP.SMethod m + -> LSP.Message m + -> Forwarding m +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 -> handleElsewhere "Exit" + LSP.SWorkspaceDidChangeWorkspaceFolders -> ForwardNotification params AllNotification + LSP.SWorkspaceDidChangeConfiguration -> ForwardNotification params AllNotification + LSP.SWorkspaceDidChangeWatchedFiles -> ForwardNotification params AllNotification + 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 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 + LSP.ReqMess LSP.RequestMessage {_id, _method, _params} -> ExplicitHandler $ \sendClient _ -> + sendClient $ LSP.FromServerRsp _method $ LSP.ResponseMessage "2.0" (Just _id) (Right Aeson.Null) + _ -> showFatal "Got unpexpected daml/keepAlive response type from client" + + -- Other custom messages are notifications from server + LSP.SCustomMethod _ -> ignore + + -- We only add the typesignature.add command, which simply sends a WorkspaceEdit with a single file modification + -- We can take the file path from that modification + LSP.SWorkspaceExecuteCommand -> + case params ^. LSP.params . LSP.command of + "typesignature.add" -> + -- Fun lens: + -- RequestMessage -> ExecuteCommandParams -> Aeson.Value -> WorkspaceEdit -> WorkspaceEditMap -> Uri + let path = + fromMaybe "Invalid arguments from typesignature.add" $ + params + ^? LSP.params + . LSP.arguments + . _Just + . to (\(LSP.List a) -> a) + . _head + . Aeson._JSON @Aeson.Value @LSP.WorkspaceEdit + . LSP.changes + . _Just + . to HM.keys + . _head + . uriFilePathPrism + in ForwardRequest params $ Single path + cmd -> showFatal $ "Unknown execute command: " <> cmd + + LSP.SWindowWorkDoneProgressCancel -> handleElsewhere "WindowWorkDoneProgressCancel" + LSP.SCancelRequest -> ForwardNotification params AllNotification + -- Unsupported by GHCIDE: + LSP.SWorkspaceSymbol -> unsupported "WorkspaceSymbol" + LSP.STextDocumentTypeDefinition -> unsupported "TextDocumentTypeDefinition" + LSP.STextDocumentImplementation -> unsupported "TextDocumentImplementation" + LSP.STextDocumentReferences -> unsupported "TextDocumentReferences" + LSP.STextDocumentDocumentHighlight -> unsupported "TextDocumentDocumentHighlight" + LSP.STextDocumentDocumentColor -> unsupported "TextDocumentDocumentColor" + LSP.SDocumentLinkResolve -> unsupported "DocumentLinkResolve" + LSP.STextDocumentFormatting -> unsupported "TextDocumentFormatting" + LSP.STextDocumentRangeFormatting -> unsupported "TextDocumentRangeFormatting" + LSP.STextDocumentRename -> unsupported "TextDocumentRename" + LSP.STextDocumentPrepareRename -> unsupported "TextDocumentPrepareRename" + LSP.STextDocumentFoldingRange -> unsupported "TextDocumentFoldingRange" + LSP.STextDocumentSelectionRange -> unsupported "TextDocumentSelectionRange" + LSP.STextDocumentPrepareCallHierarchy -> unsupported "TextDocumentPrepareCallHierarchy" + LSP.SCompletionItemResolve -> unsupported "CompletionItemResolve" + LSP.SCodeLensResolve -> unsupported "CodeLensResolve" + LSP.SCallHierarchyIncomingCalls -> unsupported "CallHierarchyIncomingCalls" + LSP.SCallHierarchyOutgoingCalls -> unsupported "CallHierarchyOutgoingCalls" + LSP.STextDocumentSemanticTokens -> unsupported "TextDocumentSemanticTokens" + LSP.STextDocumentSemanticTokensFull -> unsupported "TextDocumentSemanticTokensFull" + LSP.STextDocumentSemanticTokensFullDelta -> unsupported "TextDocumentSemanticTokensFullDelta" + LSP.STextDocumentSemanticTokensRange -> unsupported "TextDocumentSemanticTokensRange" + LSP.SWorkspaceSemanticTokensRefresh -> unsupported "WorkspaceSemanticTokensRefresh" + +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 miState uri + +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 :: MultiIdeState -> LSP.Uri -> Maybe FilePath +filePathFromURI miState uri = + LSP.uriToFilePath uri + <|> do + parsedUri <- URI.parseURI $ T.unpack $ LSP.getUri uri + case URI.uriScheme parsedUri of + "daml:" -> do + vr <- uriToVirtualResource parsedUri + pure $ LSP.fromNormalizedFilePath $ vrScenarioFile vr + "untitled:" -> + pure $ unPackageHome $ misDefaultPackagePath miState + _ -> Nothing diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Handlers.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Handlers.hs new file mode 100644 index 000000000000..ad0307683c12 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Handlers.hs @@ -0,0 +1,319 @@ +-- 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 TypeFamilies #-} + +module DA.Cli.Damlc.Command.MultiIde.Handlers (subIdeMessageHandler, clientMessageHandler) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM.TMVar +import Control.Concurrent.MVar +import Control.Lens +import Control.Monad +import Control.Monad.STM +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as B +import DA.Cli.Damlc.Command.MultiIde.ClientCommunication +import DA.Cli.Damlc.Command.MultiIde.Forwarding +import DA.Cli.Damlc.Command.MultiIde.OpenFiles +import DA.Cli.Damlc.Command.MultiIde.PackageData +import DA.Cli.Damlc.Command.MultiIde.Parsing +import DA.Cli.Damlc.Command.MultiIde.Prefixing +import DA.Cli.Damlc.Command.MultiIde.SdkInstall +import DA.Cli.Damlc.Command.MultiIde.SubIdeManagement +import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Cli.Damlc.Command.MultiIde.DarDependencies (resolveSourceLocation, unpackDar, unpackedDarsLocation) +import DA.Daml.LanguageServer.SplitGotoDefinition +import Data.Foldable (traverse_) +import Data.List (find, isInfixOf) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP +import System.Exit (exitSuccess) +import System.FilePath.Posix (takeDirectory, takeExtension, takeFileName) + +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 + +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 () -> SubIdeInstance -> B.ByteString -> IO () +subIdeMessageHandler miState unblock ide bs = do + 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 (misFromClientMethodTrackerVar 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 + prefixer = + addProgressTokenPrefixToServerMessage (ideMessageIdPrefix ide) + . addLspPrefixToServerMessage ide + mPrefixedMsg :: Maybe LSP.FromServerMessage + mPrefixedMsg = prefixer <$> mMsg + + forM_ mPrefixedMsg $ \msg -> do + -- If its a request (builtin or custom), save it for response handling. + putFromServerMessage miState (ideHome ide) msg + + logDebug miState "Message successfully parsed and prefixed." + case msg of + LSP.FromServerRsp LSP.SInitialize LSP.ResponseMessage {_result} -> do + logDebug miState "Got initialization reply, sending initialized and unblocking" + holdingIDEsAtomic miState $ \ides -> do + let ideData = lookupSubIde (ideHome ide) ides + sendPackageDiagnostic miState ideData + unsafeSendSubIdeSTM ide $ LSP.FromClientMess LSP.SInitialized $ LSP.NotificationMessage "2.0" LSP.SInitialized (Just LSP.InitializedParams) + unblock + 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 + 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 + 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, forward error + Left err -> reply $ Left err + -- Request didn't find any location information, forward "nothing" + Right Nothing -> replyLocations [] + -- SubIde containing the reference also contained the definition, so returned no name to lookup + -- Simply forward this location + Right (Just (TryGetDefinitionResult loc Nothing)) -> replyLocations [loc] + -- 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 + logDebug miState $ "Got name in result! Backup location is " <> show loc + mSourceLocation <- Map.lookup (UnitId $ tgdnPackageUnitId name) <$> atomically (readTMVar $ misMultiPackageMappingVar 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 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 + 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 + 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 + 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 + logDebug miState $ "Backwarding request " <> show method <> ":\n" <> show msg + sendClient miState msg + LSP.FromServerRsp method _ -> do + logDebug miState $ "Backwarding response to " <> show method <> ":\n" <> show msg + sendClient miState msg + +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") -> do + home <- getSourceFileHome miState path + addOpenFile miState home $ DamlFile path + (LSP.STextDocumentDidClose, ".daml") -> do + home <- getSourceFileHome miState path + removeOpenFile miState home $ DamlFile path + -- Also remove from the source mapping, in case project structure changes while we're not tracking the file + sourceFileHomeHandleDamlFileDeleted miState 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' SMethodWithSender -> LSP.FromClientMessage + castFromClientMessage = \case + LSP.FromClientMess method params -> LSP.FromClientMess method params + LSP.FromClientRsp (SMethodWithSender method _) params -> LSP.FromClientRsp method params + + val :: Aeson.Value + val = er "eitherDecode" $ Aeson.eitherDecodeStrict bs + + unPrefixedMsg <- either error id <$> parseClientMessageWithTracker (misFromServerMethodTrackerVar miState) val + let msg = addProgressTokenPrefixToClientMessage unPrefixedMsg + + case msg of + -- 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 (misInitParamsVar miState) _params + -- 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 + putFromServerCoordinatorMessage miState registerFileWatchersMessage + sendClient miState 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 -> holdingIDEsAtomic miState $ \ides -> + let mIde = find (\ideData -> (ideMessageIdPrefix <$> ideDataMain ideData) == Just prefix) ides + in traverse_ (`unsafeSendSubIdeSTM` newMsg) $ mIde >>= ideDataMain + + LSP.FromClientMess (LSP.SCustomMethod t) (LSP.NotMess notif) | t == damlSdkInstallCancelMethod -> + handleSdkInstallClientCancelled miState notif + + -- Special handing for STextDocumentDefinition to ask multiple IDEs (the W approach) + -- When a getDefinition is requested, we cast this request into a tryGetDefinition + -- This is a method that will take the same logic path as getDefinition, but will also return an + -- identifier in the cases where it knows the identifier wasn't defined in the package that referenced it + -- When we receive this name, we lookup against the multi-package.yaml for a package that matches where the identifier + -- came from. If we find one, we ask (and create if needed) the SubIde that contains the identifier where its defined. + -- (this is via the getDefinitionByName message) + -- We also send the backup known incorrect location from the tryGetDefinition, such that if the subIde containing the identifier + -- 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 miState req + lspId = castLspId _id + method = LSP.SCustomMethod "daml/tryGetDefinition" + 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" + atomically $ sourceFileHomeHandleDamlYamlChanged miState home + allowIdeSdkInstall miState home + case changeType of + LSP.FcDeleted -> do + shutdownIdeByHome miState home + handleRemovedPackageOpenFiles miState home + LSP.FcCreated -> do + handleCreatedPackageOpenFiles miState home + rebootIdeByHome miState home + LSP.FcChanged -> 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 $ misDarDependentPackagesVar 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 -> atomically $ sourceFileHomeHandleDamlFileDeleted 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 $ misSubIdesVar 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 miState meth params of + ForwardRequest mess (Single path) -> do + logDebug miState $ "single req on method " <> show meth <> " over path " <> path + let LSP.RequestMessage {_id, _method} = mess + msg' = castFromClientMessage msg + sendSubIdeByPath miState path msg' + + ForwardRequest mess (AllRequest combine) -> do + logDebug miState $ "all req on method " <> show meth + let LSP.RequestMessage {_id, _method} = mess + 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 (misFromClientMethodTrackerVar 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 + 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) + -- 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 + -- 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 + (LSP.SWindowShowMessageRequest, Just lspId) -> handleSdkInstallPromptResponse miState lspId _result + _ -> pure () diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/OpenFiles.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/OpenFiles.hs new file mode 100644 index 000000000000..ef797dee9639 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/OpenFiles.hs @@ -0,0 +1,106 @@ +-- 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.OpenFiles ( + addOpenFile, + removeOpenFile, + handleRemovedPackageOpenFiles, + handleCreatedPackageOpenFiles, + sendPackageDiagnostic, +) where + +import Control.Monad +import Control.Monad.STM +import DA.Cli.Damlc.Command.MultiIde.ClientCommunication +import DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Cli.Damlc.Command.MultiIde.Types +import Data.Foldable (traverse_) +import Data.List (isPrefixOf) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Extended as TE +import GHC.Conc (unsafeIOToSTM) +import System.FilePath (()) + +sendPackageDiagnostic :: MultiIdeState -> SubIdeData -> STM () +sendPackageDiagnostic miState ideData = do + let makeMessage = + case ideDataDisabled ideData of + IdeDataDisabled {iddSeverity, iddMessage} -> fullFileDiagnostic iddSeverity $ T.unpack iddMessage + _ -> clearDiagnostics + files = (unPackageHome (ideDataHome ideData) "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData) + in traverse_ (sendClientSTM miState) $ makeMessage <$> files + +onOpenFiles :: MultiIdeState -> PackageHome -> (Set.Set DamlFile -> Set.Set DamlFile) -> STM () +onOpenFiles miState home f = modifyTMVarM (misSubIdesVar miState) $ \ides -> do + let ideData = lookupSubIde home ides + ideData' = ideData {ideDataOpenFiles = f $ ideDataOpenFiles ideData} + sendPackageDiagnostic miState ideData' + pure $ Map.insert home ideData' ides + +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 + +-- Logic for moving open files between subIdes when packages are created/destroyed + +-- When a daml.yaml is removed, its openFiles need to be distributed to another SubIde, else we'll forget that the client opened them +-- We handle this by finding a new home (using getSourceFileHome) for each open file of the current subIde, and assigning to that +-- We also send the open file notification to the new subIde(s) if they're already running +handleRemovedPackageOpenFiles :: MultiIdeState -> PackageHome -> IO () +handleRemovedPackageOpenFiles miState home = withIDEsAtomic_ miState $ \ides -> do + let ideData = lookupSubIde home ides + moveOpenFile :: SubIdes -> DamlFile -> STM SubIdes + moveOpenFile ides openFile = do + -- getSourceFileHome caches on a directory level, so won't do that many filesystem operations + newHome <- getSourceFileHome miState $ unDamlFile openFile + let newHomeIdeData = lookupSubIde newHome ides + newHomeIdeData' = newHomeIdeData {ideDataOpenFiles = Set.insert openFile $ ideDataOpenFiles newHomeIdeData} + -- If we're moving the file to a disabled IDE, it should get the new warning + sendPackageDiagnostic miState newHomeIdeData' + forM_ (ideDataMain newHomeIdeData) $ \ide -> do + -- Acceptable IO as read only operation + content <- unsafeIOToSTM $ TE.readFileUtf8 $ unDamlFile openFile + unsafeSendSubIdeSTM ide $ openFileNotification openFile content + pure $ Map.insert newHome newHomeIdeData' ides + ides' <- foldM moveOpenFile ides $ ideDataOpenFiles ideData + pure $ Map.insert home (ideData {ideDataOpenFiles = mempty}) ides' + +-- When a daml.yaml is created, we potentially move openFiles from other subIdes to this one +-- We do this by finding all SubIdes that sit above this package in the directory +-- (plus the default package, which is said to sit above all other packages) +-- We iterate their open files for any that sit below this package +-- i.e. this package sits between a daml file and its daml.yaml +-- We move these open files to the new package, sending Closed file messages to their former IDE +-- We also assume no subIde for this package existed already, as its daml.yaml was just created +-- so there is no need to send Open file messages to it +handleCreatedPackageOpenFiles :: MultiIdeState -> PackageHome -> IO () +handleCreatedPackageOpenFiles miState home = withIDEsAtomic_ miState $ \ides -> do + -- Iterate ides, return a list of open files, update ides and run monadically + let shouldConsiderIde :: PackageHome -> Bool + shouldConsiderIde oldHome = + oldHome == misDefaultPackagePath miState || + unPackageHome oldHome `isPrefixOf` unPackageHome home && oldHome /= home + shouldMoveFile :: DamlFile -> Bool + shouldMoveFile (DamlFile damlFilePath) = unPackageHome home `isPrefixOf` damlFilePath + handleIde :: (SubIdes, Set.Set DamlFile) -> (PackageHome, SubIdeData) -> STM (SubIdes, Set.Set DamlFile) + handleIde (ides, damlFiles) (oldHome, oldIdeData) | shouldConsiderIde oldHome = do + let openFilesToMove = Set.filter shouldMoveFile $ ideDataOpenFiles oldIdeData + updatedOldIdeData = oldIdeData {ideDataOpenFiles = ideDataOpenFiles oldIdeData Set.\\ openFilesToMove} + forM_ (ideDataMain oldIdeData) $ \ide -> forM_ openFilesToMove $ unsafeSendSubIdeSTM ide . closeFileNotification + pure (Map.insert oldHome updatedOldIdeData ides, openFilesToMove <> damlFiles) + handleIde (ides, damlFiles) (oldHome, oldIdeData) = + pure (Map.insert oldHome oldIdeData ides, damlFiles) + (ides', movedFiles) <- foldM handleIde mempty $ Map.toList ides + let ideData = lookupSubIde home ides + -- Invalidate the home cache for every moved file + traverse_ (sourceFileHomeHandleDamlFileDeleted miState . unDamlFile) movedFiles + pure $ Map.insert home (ideData {ideDataOpenFiles = movedFiles <> ideDataOpenFiles ideData}) ides' diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/PackageData.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/PackageData.hs new file mode 100644 index 000000000000..3f7846a714de --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/PackageData.hs @@ -0,0 +1,139 @@ +-- 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.PackageData (updatePackageData) where + +import qualified "zip-archive" Codec.Archive.Zip as Zip +import Control.Concurrent.STM.TMVar +import Control.Exception(SomeException, displayException, 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.ByteString.Lazy as BSL +import DA.Cli.Damlc.Command.MultiIde.ClientCommunication +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Cli.Damlc.Command.MultiIde.Types +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 Data.Either.Extra (eitherToMaybe) +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, isJust) +import qualified Data.Set as Set +import qualified Language.LSP.Types as LSP +import System.Directory (doesFileExist) +import System.FilePath.Posix (()) + +{- +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: + Make a multi-package.yaml at the root and reload the editor please :) + 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 = misMultiPackageHome miState + + -- Take locks, throw away current data + atomically $ do + void $ takeTMVar (misMultiPackageMappingVar miState) + void $ takeTMVar (misDarDependentPackagesVar 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 (misMultiPackageMappingVar miState) Map.empty + void $ tryPutTMVar (misDarDependentPackagesVar miState) Map.empty + -- Show the failure as a diagnostic on the multi-package.yaml + sendClient miState $ fullFileDiagnostic LSP.DsError ("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 + mPackageSummary <- lift $ fmap eitherToMaybe $ packageSummaryFromDamlYaml packagePath + case mPackageSummary of + Just packageSummary -> do + allDepsValid <- isJust . sequence <$> traverse getDarUnitId (psDeps packageSummary) + pure (if allDepsValid then Nothing else Just packagePath, Just (packagePath, psUnitId packageSummary, psDeps packageSummary)) + _ -> 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 (misMultiPackageMappingVar miState) multiPackageMapping + putTMVar (misDarDependentPackagesVar miState) darDependentPackages + + pure invalidHomes 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 new file mode 100644 index 000000000000..0470090287bb --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Parsing.hs @@ -0,0 +1,284 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE GADTs #-} + +module DA.Cli.Damlc.Command.MultiIde.Parsing ( + getUnrespondedRequestsToResend, + getUnrespondedRequestsFallbackResponses, + onChunks, + parseClientMessageWithTracker, + parseServerMessageWithTracker, + putChunk, + putReqMethodAll, + putReqMethodSingleFromClient, + putReqMethodSingleFromServer, + putReqMethodSingleFromServerCoordinator, + putFromServerMessage, + putFromServerCoordinatorMessage, + putSingleFromClientMessage, +) where + +import Control.Concurrent.STM.TVar +import Control.Lens +import Control.Monad.STM +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.Attoparsec.ByteString.Lazy as Attoparsec +import qualified Data.ByteString as B +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 +decimal = B.foldl' step 0 `fmap` Attoparsec.takeWhile1 (\w -> w - 48 <= 9) + where step a w = a * 10 + fromIntegral (w - 48) + +contentChunkParser :: Attoparsec.Parser B.ByteString +contentChunkParser = do + _ <- Attoparsec.string "Content-Length: " + len <- decimal + _ <- Attoparsec.string "\r\n\r\n" + 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 + +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 + hTryFlush handle + +putReqMethodSingleFromServer + :: forall (m :: LSP.Method 'LSP.FromServer 'LSP.Request) + . 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 (misFromServerMethodTrackerVar miState) home (mess ^. LSP.id) method + (LSP.IsServerEither, LSP.ReqMess mess) -> putReqMethodSingleFromServer (misFromServerMethodTrackerVar miState) home (mess ^. LSP.id) method + _ -> pure () +putFromServerMessage _ _ _ = pure () + +-- Takes a message from server coordinator and stores it if its a request, so that later messages from the client can deduce response context +putFromServerCoordinatorMessage :: MultiIdeState -> LSP.FromServerMessage -> IO () +putFromServerCoordinatorMessage miState (LSP.FromServerMess method mess) = + case (LSP.splitServerMethod method, mess) of + (LSP.IsServerReq, _) -> putReqMethodSingleFromServerCoordinator (misFromServerMethodTrackerVar miState) (mess ^. LSP.id) method + (LSP.IsServerEither, LSP.ReqMess mess) -> putReqMethodSingleFromServerCoordinator (misFromServerMethodTrackerVar miState) (mess ^. LSP.id) method + _ -> pure () +putFromServerCoordinatorMessage _ _ = pure () + +putReqMethodSingleFromClient + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . 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 (misFromClientMethodTrackerVar miState) (mess ^. LSP.id) method msg home + (LSP.IsClientEither, LSP.ReqMess mess) -> putReqMethodSingleFromClient (misFromClientMethodTrackerVar 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 + -> LSP.FromClientMessage + -> [PackageHome] + -> ResponseCombiner m + -> IO () +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) + . MethodTrackerVar f -> LSP.LspId m -> TrackedMethod m -> IO () +putReqMethod tracker id method = atomically $ modifyTVar' tracker $ \im -> + fromMaybe im $ IM.insertIxMap id method im + +pickReqMethodTo + :: forall (f :: LSP.From) r + . MethodTrackerVar f + -> ((forall (m :: LSP.Method f 'LSP.Request) + . LSP.LspId m + -> (Maybe (TrackedMethod m), MethodTracker f) + ) -> (r, Maybe (MethodTracker f))) + -> IO r +pickReqMethodTo tracker handler = atomically $ do + im <- readTVar tracker + let (r, mayNewIM) = handler (flip IM.pickFromIxMap im) + forM_ mayNewIM $ writeTVar tracker + pure r + +-- We're forced to give a result of type `(SMethod m, a m)` by parseServerMessage and parseClientMessage, but we want to include the updated MethodTracker +-- so we use Product to ensure our result has the SMethod and our MethodTracker +wrapParseMessageLookup + :: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request) + . (Maybe (TrackedMethod m), MethodTracker f) + -> Maybe + ( LSP.SMethod m + , Product TrackedMethod (Const (MethodTracker f)) m + ) +wrapParseMessageLookup (mayTM, newIM) = + fmap (\tm -> (tmMethod tm, Pair tm (Const newIM))) mayTM + +-- 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 -> 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) + -- 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 = (home, LSP._result rsp) : tamResponses tm + , tamRemainingResponsePackageHomes = delete home $ tamRemainingResponsePackageHomes 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 + in (Right Nothing, Just insertedIxMap) + Left msg -> (Left msg, Nothing) + +-- Similar to parseServerMessageWithTracker but using Client message types, and checking previous requests from server +-- Also does not include the multi-reply logic +-- For responses, gives the ide that sent the initial request +parseClientMessageWithTracker + :: MethodTrackerVar 'LSP.FromServer + -> Aeson.Value + -> 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 mHome) (Const newIxMap)) rsp) -> + (Right (LSP.FromClientRsp (SMethodWithSender method mHome) rsp), Just newIxMap) + Left msg -> (Left msg, Nothing) + +-- 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 (misFromClientMethodTrackerVar 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 misFromClientMethodTrackerVar 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 new file mode 100644 index 000000000000..ce05f2368dba --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Prefixing.hs @@ -0,0 +1,212 @@ +-- 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 GADTs #-} + +-- This module handles prefixing of identifiers generated by the SubIdes, so that they are unique to the client, but are returned in the same form to the servers. +-- It has been implemented to be stateless for simplicity +module DA.Cli.Damlc.Command.MultiIde.Prefixing ( + addProgressTokenPrefixToClientMessage, + addProgressTokenPrefixToServerMessage, + addLspPrefixToServerMessage, + stripLspPrefix, + stripWorkDoneProgressCancelTokenPrefix, +) where + +import Control.Lens +import Control.Monad +import qualified Data.Text as T +import Data.Tuple (swap) +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP +import DA.Cli.Damlc.Command.MultiIde.Types + +-- ProgressToken Prefixing +-- Progress tokens can be created on both client and subIdes. They are then reported on by a subIde, and cancelled by the client. +-- We need to avoid collisions between tokens created by different subIdes. +-- Server created progress tokens use the SWindowWorkDoneProgressCreate notification. We prefix these tokens uniquely to the subIde that created them. +-- Handled in addProgressTokenPrefixToServerMessage +-- Client created progress tokens are created alongside requests, `getProgressLenses` creates lenses for these tokens. We prefix these with `client` +-- All prefixed tokens also include their original type, so the transformation can be safely reversed. +-- Handled in addProgressTokenPrefixToClientMessage +-- Progress messages +-- Sent from subIdes, these are always forwarded to the client. However, depending on what created the Token, the prefix will need changing. +-- If the subIde created the token, the progress message token will be unprefixed. +-- We check the first character of the token. Neither server or client can create tokens starting with non-hex character. Our prefixing starts with `i` or `t` +-- If there is no prefix, we add the prefix of the sending subIde. No subIde should ever give progress reports for tokens created by other subIdes. +-- If the client created the token, it will have the client prefix. We detect this and remove it, so the client sees the exact name it created. +-- Handled in addProgressTokenPrefixToServerMessage +-- Cancel messages +-- Sent by the client, forwarded to either all or a specific subIde. +-- If the token was created by the client, it will have no prefix. We add the prefix and broadcast to all subIdes +-- This is safe because it is impossible for a subIde to generate a token matching the prefixed client token, so the correct subIde will delete the token, and the rest will ignore +-- If the token was created by a subIde, it will have the subIde's unique prefix. We strip this from the message, and return it to MultiIde.hs. +-- The message handling there will lookup the IDE matching this prefix and send the message to it. If no IDE exists, we can safely drop the message, as the IDE has been removed. + +-- | Convenience type for prefixes +data ProgressTokenPrefix + = SubIdePrefix T.Text + | ClientPrefix + +progressTokenPrefixToText :: ProgressTokenPrefix -> T.Text +progressTokenPrefixToText (SubIdePrefix t) = t +progressTokenPrefixToText ClientPrefix = "client" + +progressTokenPrefixFromMaybe :: Maybe T.Text -> ProgressTokenPrefix +progressTokenPrefixFromMaybe = maybe ClientPrefix SubIdePrefix + +-- | Reversible ProgressToken prefixing +-- Given ProgressTokens can be int or text, we encode them as text as well as a tag to say if the original was an int +-- Such that ProgressNumericToken 10 -> ProgressTextToken "iPREFIX-10" +-- and ProgressTextToken "hello" -> ProgressTextToken "tPREFIX-hello" +addProgressTokenPrefix :: ProgressTokenPrefix -> LSP.ProgressToken -> LSP.ProgressToken +addProgressTokenPrefix prefix (LSP.ProgressNumericToken t) = LSP.ProgressTextToken $ "i" <> progressTokenPrefixToText prefix <> "-" <> T.pack (show t) +addProgressTokenPrefix prefix (LSP.ProgressTextToken t) = LSP.ProgressTextToken $ "t" <> progressTokenPrefixToText prefix <> "-" <> t + +progressTokenSplitPrefix :: T.Text -> (T.Text, Maybe T.Text) +progressTokenSplitPrefix = bimap T.tail (mfilter (/="client") . Just) . swap . T.breakOn "-" + +-- Removes prefix, returns the subIde prefix if the token was created by a subIde +stripProgressTokenPrefix :: LSP.ProgressToken -> (LSP.ProgressToken, Maybe ProgressTokenPrefix) +stripProgressTokenPrefix (LSP.ProgressTextToken (T.uncons -> Just ('i', rest))) = + bimap (LSP.ProgressNumericToken . read . T.unpack) (Just . progressTokenPrefixFromMaybe) $ progressTokenSplitPrefix rest +stripProgressTokenPrefix (LSP.ProgressTextToken (T.uncons -> Just ('t', rest))) = + bimap LSP.ProgressTextToken (Just . progressTokenPrefixFromMaybe) $ progressTokenSplitPrefix rest +stripProgressTokenPrefix t = (t, Nothing) + +-- Prefixes the SWindowWorkDoneProgressCreate and SProgress messages from subIde. Rest are unchanged. +addProgressTokenPrefixToServerMessage :: T.Text -> LSP.FromServerMessage -> LSP.FromServerMessage +addProgressTokenPrefixToServerMessage prefix (LSP.FromServerMess LSP.SWindowWorkDoneProgressCreate req) = + LSP.FromServerMess LSP.SWindowWorkDoneProgressCreate $ req & LSP.params . LSP.token %~ addProgressTokenPrefix (SubIdePrefix prefix) +addProgressTokenPrefixToServerMessage prefix (LSP.FromServerMess LSP.SProgress notif) = + case stripProgressTokenPrefix $ notif ^. LSP.params . LSP.token of + -- ProgressToken was created by this subIde, add its usual prefix + (unprefixedToken, Nothing) -> + let prefixedToken = addProgressTokenPrefix (SubIdePrefix prefix) unprefixedToken + in LSP.FromServerMess LSP.SProgress $ notif & LSP.params . LSP.token .~ prefixedToken + -- ProgressToken was created by client, send back the unprefixed token + (unprefixedToken, Just ClientPrefix) -> LSP.FromServerMess LSP.SProgress $ notif & LSP.params . LSP.token .~ unprefixedToken + (_, Just (SubIdePrefix t)) -> error $ "SubIde with prefix " <> T.unpack t <> " is somehow aware of its own prefixing. Something is very wrong." +addProgressTokenPrefixToServerMessage _ msg = msg + +-- Prefixes client created progress tokens for all requests that can create them. +addProgressTokenPrefixToClientMessage :: LSP.FromClientMessage' a -> LSP.FromClientMessage' a +addProgressTokenPrefixToClientMessage = \case + mess@(LSP.FromClientMess method params) -> + case LSP.splitClientMethod method of + LSP.IsClientReq -> do + let progressLenses = getProgressLenses method + doAddProgressTokenPrefix + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . Maybe (ReifiedLens' (LSP.RequestMessage m) (Maybe LSP.ProgressToken)) + -> LSP.RequestMessage m + -> LSP.RequestMessage m + doAddProgressTokenPrefix = maybe id $ \lens -> runLens lens . mapped %~ addProgressTokenPrefix ClientPrefix + params' = doAddProgressTokenPrefix (workDoneLens progressLenses) $ doAddProgressTokenPrefix (partialResultLens progressLenses) params + in LSP.FromClientMess method params' + _ -> mess + rsp@LSP.FromClientRsp {} -> rsp + +-- Convenience wrapper for the reified progress token lenses. +-- Note that there are 2 types, workDone and partialResult. +-- Most messages with progress have both, but ssome only have workDone +data ProgressLenses (m :: LSP.Method 'LSP.FromClient 'LSP.Request) = ProgressLenses + { workDoneLens :: Maybe (ReifiedLens' (LSP.RequestMessage m) (Maybe LSP.ProgressToken)) + , partialResultLens :: Maybe (ReifiedLens' (LSP.RequestMessage m) (Maybe LSP.ProgressToken)) + } + +getProgressLenses :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request). LSP.SMethod m -> ProgressLenses m +getProgressLenses = \case + LSP.SInitialize -> workDone + LSP.SWorkspaceSymbol -> both + LSP.SWorkspaceExecuteCommand -> workDone + LSP.STextDocumentCompletion -> both + LSP.STextDocumentHover -> workDone + LSP.STextDocumentDeclaration -> both + LSP.STextDocumentDefinition -> both + LSP.STextDocumentTypeDefinition -> both + LSP.STextDocumentImplementation -> both + LSP.STextDocumentReferences -> both + LSP.STextDocumentDocumentHighlight -> both + LSP.STextDocumentDocumentSymbol -> both + LSP.STextDocumentCodeAction -> both + LSP.STextDocumentCodeLens -> both + LSP.STextDocumentDocumentLink -> both + LSP.STextDocumentDocumentColor -> both + LSP.STextDocumentColorPresentation -> both + LSP.STextDocumentFormatting -> workDone + LSP.STextDocumentRangeFormatting -> workDone + LSP.STextDocumentRename -> workDone + LSP.STextDocumentFoldingRange -> both + LSP.STextDocumentSelectionRange -> both + LSP.STextDocumentPrepareCallHierarchy -> workDone + LSP.SCallHierarchyIncomingCalls -> both + LSP.SCallHierarchyOutgoingCalls -> both + LSP.STextDocumentSemanticTokensFull -> both + LSP.STextDocumentSemanticTokensFullDelta -> both + LSP.STextDocumentSemanticTokensRange -> both + _ -> ProgressLenses Nothing Nothing + where + workDone + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . LSP.HasWorkDoneToken (LSP.MessageParams m) (Maybe LSP.ProgressToken) + => ProgressLenses m + workDone = ProgressLenses (Just $ Lens $ LSP.params . LSP.workDoneToken) Nothing + both + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . ( LSP.HasWorkDoneToken (LSP.MessageParams m) (Maybe LSP.ProgressToken) + , LSP.HasPartialResultToken (LSP.MessageParams m) (Maybe LSP.ProgressToken) + ) + => ProgressLenses m + both = ProgressLenses (Just $ Lens $ LSP.params . LSP.workDoneToken) (Just $ Lens $ LSP.params . LSP.partialResultToken) + +-- strips and returns the subIde prefix from cancel messages. Gives Nothing for client created tokens +stripWorkDoneProgressCancelTokenPrefix + :: LSP.NotificationMessage 'LSP.WindowWorkDoneProgressCancel + -> (LSP.NotificationMessage 'LSP.WindowWorkDoneProgressCancel, Maybe T.Text) +stripWorkDoneProgressCancelTokenPrefix notif = + case stripProgressTokenPrefix $ notif ^. LSP.params . LSP.token of + -- Token was created by the client, add the client prefix and broadcast to all subIdes + (unprefixedToken, Nothing) -> + let prefixedToken = addProgressTokenPrefix ClientPrefix unprefixedToken + in (notif & LSP.params . LSP.token .~ prefixedToken, Nothing) + -- Created by subIde, strip the prefix and send to the specific subIde that created it. + (unprefixedToken, Just (SubIdePrefix prefix)) -> (notif & LSP.params . LSP.token .~ unprefixedToken, Just prefix) + (_, Just ClientPrefix) -> error "Client attempted to cancel a ProgressToken with the client prefix, which it should not be aware of. Something went wrong." + +-- LspId Prefixing + +-- We need to ensure all IDs from different subIdes are unique to the client, so we prefix them. +-- Given IDs can be int or text, we encode them as text as well as a tag to say if the original was an int +-- Such that IdInt 10 -> IdString "iPREFIX-10" +-- and IdString "hello" -> IdString "tPREFIX-hello" +addLspPrefix + :: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request) + . T.Text + -> LSP.LspId m + -> LSP.LspId m +addLspPrefix prefix (LSP.IdInt t) = LSP.IdString $ "i" <> prefix <> "-" <> T.pack (show t) +addLspPrefix prefix (LSP.IdString t) = LSP.IdString $ "t" <> prefix <> "-" <> t + +stripLspPrefix + :: forall (f :: LSP.From) (m :: LSP.Method f 'LSP.Request) + . LSP.LspId m + -> LSP.LspId m +stripLspPrefix (LSP.IdString (T.unpack -> ('i':rest))) = LSP.IdInt $ read $ tail $ dropWhile (/='-') rest +stripLspPrefix (LSP.IdString (T.uncons -> Just ('t', rest))) = LSP.IdString $ T.tail $ T.dropWhile (/='-') rest +-- Maybe this should error? This method should only be called on LspIds that we know have been prefixed +stripLspPrefix t = t + +-- Prefixes applied to builtin and custom requests. Notifications do not have ids, responses do not need this logic. +addLspPrefixToServerMessage :: SubIdeInstance -> LSP.FromServerMessage -> LSP.FromServerMessage +addLspPrefixToServerMessage _ res@(LSP.FromServerRsp _ _) = res +addLspPrefixToServerMessage ide res@(LSP.FromServerMess method params) = + case LSP.splitServerMethod method of + LSP.IsServerReq -> LSP.FromServerMess method $ params & LSP.id %~ addLspPrefix (ideMessageIdPrefix ide) + LSP.IsServerNot -> res + LSP.IsServerEither -> + case params of + LSP.ReqMess params' -> LSP.FromServerMess method $ LSP.ReqMess $ params' & LSP.id %~ addLspPrefix (ideMessageIdPrefix ide) + LSP.NotMess _ -> res diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SdkInstall.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SdkInstall.hs new file mode 100644 index 000000000000..53e94b002145 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SdkInstall.hs @@ -0,0 +1,256 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} + +module DA.Cli.Damlc.Command.MultiIde.SdkInstall ( + allowIdeSdkInstall, + ensureIdeSdkInstalled, + handleSdkInstallClientCancelled, + handleSdkInstallPromptResponse, + untrackPackageSdkInstall, +) where + +import Control.Concurrent.Async +import Control.Concurrent.MVar +import Control.Concurrent.STM.TMVar +import Control.Exception (SomeException, displayException) +import Control.Lens ((^.)) +import Control.Monad (foldM, forM_) +import Control.Monad.STM +import Data.Aeson (fromJSON, toJSON) +import Data.Either.Extra (eitherToMaybe) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import DA.Cli.Damlc.Command.MultiIde.ClientCommunication +import DA.Cli.Damlc.Command.MultiIde.OpenFiles +import DA.Cli.Damlc.Command.MultiIde.Parsing +import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Daml.Assistant.Cache (CacheTimeout (..)) +import DA.Daml.Assistant.Env +import DA.Daml.Assistant.Install +import DA.Daml.Assistant.Types +import DA.Daml.Assistant.Util (tryConfig) +import DA.Daml.Assistant.Version +import DA.Daml.Project.Config +import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types.Lens as LSP + +-- Check if an SDK is installed, transform the subIDE data to disable it if needed +ensureIdeSdkInstalled :: MultiIdeState -> UnresolvedReleaseVersion -> PackageHome -> SubIdeData -> IO SubIdeData +ensureIdeSdkInstalled miState ver home ideData = do + installDatas <- atomically $ takeTMVar $ misSdkInstallDatasVar miState + let installData = getSdkInstallData ver installDatas + (newInstallDatas, mDisableDiagnostic) <- case sidStatus installData of + SISCanAsk -> do + damlPath <- getDamlPath + installedVersions <- getInstalledSdkVersions damlPath + let versionIsInstalled = any ((unwrapUnresolvedReleaseVersion ver==) . releaseVersionFromReleaseVersion) installedVersions + + if versionIsInstalled + then pure (installDatas, Nothing) + else do + -- Ask the user if they want to install + let verStr = T.pack $ unresolvedReleaseVersionToString ver + lspId = LSP.IdString $ verStr <> "-sdk-install-request" + messageContent = "This package uses the release version " <> verStr <> " which is not installed on this system.\n" + <> "The IDE cannot give intelligence on this package without this SDK. Would you like to install it?" + message = showMessageRequest lspId LSP.MtError messageContent ["Install SDK " <> verStr, "Do not install"] + installData' = + installData + { sidPendingHomes = Set.insert home $ sidPendingHomes installData + , sidStatus = SISAsking + } + + putFromServerCoordinatorMessage miState message + sendClient miState message + pure (Map.insert ver installData' installDatas, Just (LSP.DsError, missingSdkIdeDiagnosticMessage ver)) + -- If the home is already in the set, the diagnostic has already been sent + _ | Set.member home $ sidPendingHomes installData -> pure (installDatas, Nothing) + _ -> + let message = + case sidStatus installData of + SISInstalling _ -> (LSP.DsInfo, installingSdkIdeDiagnosticMessage ver) + SISFailed log err -> (LSP.DsError, failedInstallIdeDiagnosticMessage ver log err) + _ -> (LSP.DsError, missingSdkIdeDiagnosticMessage ver) + in pure (Map.insert ver (installData {sidPendingHomes = Set.insert home $ sidPendingHomes installData}) installDatas, Just message) + atomically $ do + putTMVar (misSdkInstallDatasVar miState) newInstallDatas + case mDisableDiagnostic of + Just (severity, message) -> do + let ideData' = ideData {ideDataDisabled = IdeDataDisabled severity message} + sendPackageDiagnostic miState ideData' + pure ideData' + Nothing -> pure ideData + +missingSdkIdeDiagnosticMessage :: UnresolvedReleaseVersion -> T.Text +missingSdkIdeDiagnosticMessage ver = + let verText = T.pack $ unresolvedReleaseVersionToString ver + in "Missing required Daml SDK version " <> verText <> " to create development environment.\n" + <> "Install this version via `daml install " <> verText <> "`, or save the daml.yaml to be prompted" + +installingSdkIdeDiagnosticMessage :: UnresolvedReleaseVersion -> T.Text +installingSdkIdeDiagnosticMessage ver = + "Installing Daml SDK version " <> T.pack (unresolvedReleaseVersionToString ver) + +failedInstallIdeDiagnosticMessage :: UnresolvedReleaseVersion -> T.Text -> SomeException -> T.Text +failedInstallIdeDiagnosticMessage ver outputLog err = + "Failed to install Daml SDK version " <> T.pack (unresolvedReleaseVersionToString ver) <> " due to the following:\n" + <> (if outputLog == "" then "" else outputLog <> "\n") + <> T.pack (displayException err) + +-- Set the install status for a version, updating all pending packages with diagnostics if needed +updateSdkInstallStatus :: MultiIdeState -> SdkInstallDatas -> UnresolvedReleaseVersion -> LSP.DiagnosticSeverity -> T.Text -> SdkInstallStatus -> IO SdkInstallDatas +updateSdkInstallStatus miState installDatas ver severity message newStatus = do + let installData = getSdkInstallData ver installDatas + homes = sidPendingHomes installData + disableIde :: SubIdes -> PackageHome -> STM SubIdes + disableIde ides home = do + let ideData = (lookupSubIde home ides) {ideDataDisabled = IdeDataDisabled severity message} + sendPackageDiagnostic miState ideData + pure $ Map.insert home ideData ides + withIDEsAtomic miState $ \ides -> do + ides' <- foldM disableIde ides homes + pure (ides', Map.insert ver (installData {sidStatus = newStatus}) installDatas) + +releaseVersionFromLspId :: LSP.LspId 'LSP.WindowShowMessageRequest -> Maybe UnresolvedReleaseVersion +releaseVersionFromLspId (LSP.IdString lspIdStr) = T.stripSuffix "-sdk-install-request" lspIdStr >>= eitherToMaybe . parseUnresolvedVersion +releaseVersionFromLspId _ = Nothing + +-- Handle the Client -> Coordinator response to the "Would you like to install ..." message +handleSdkInstallPromptResponse :: MultiIdeState -> LSP.LspId 'LSP.WindowShowMessageRequest -> Either LSP.ResponseError (Maybe LSP.MessageActionItem) -> IO () +handleSdkInstallPromptResponse miState (releaseVersionFromLspId -> Just ver) res = do + installDatas <- atomically $ takeTMVar $ misSdkInstallDatasVar miState + let installData = getSdkInstallData ver installDatas + changeSdkStatus :: LSP.DiagnosticSeverity -> T.Text -> SdkInstallStatus -> IO () + changeSdkStatus severity message newStatus = do + installDatas' <- updateSdkInstallStatus miState installDatas ver severity message newStatus + atomically $ putTMVar (misSdkInstallDatasVar miState) installDatas' + disableSdk = changeSdkStatus LSP.DsError (missingSdkIdeDiagnosticMessage ver) SISDenied + + case (sidStatus installData, res) of + (SISAsking, Right (Just (LSP.MessageActionItem (T.stripPrefix "Install SDK" -> Just _)))) -> do + -- Install accepted, start install process + installThread <- async $ do + setupSdkInstallReporter miState ver + outputLogVar <- newMVar "" + res <- tryForwardAsync $ installSdk ver outputLogVar $ updateSdkInstallReporter miState ver + onSdkInstallerFinished miState ver outputLogVar $ either Just (const Nothing) res + finishSdkInstallReporter miState ver + changeSdkStatus LSP.DsInfo (installingSdkIdeDiagnosticMessage ver) (SISInstalling installThread) + (SISAsking, _) -> disableSdk + (_, _) -> atomically $ putTMVar (misSdkInstallDatasVar miState) installDatas +handleSdkInstallPromptResponse _ _ _ = pure () + +-- Handle the Client -> Coordinator notification for cancelling an sdk installation +handleSdkInstallClientCancelled :: MultiIdeState -> LSP.NotificationMessage 'LSP.CustomMethod -> IO () +handleSdkInstallClientCancelled miState notif = do + forM_ (fromJSON $ notif ^. LSP.params) $ \message -> do + let ver = sicSdkVersion message + installDatas <- atomically $ takeTMVar $ misSdkInstallDatasVar miState + let installData = getSdkInstallData ver installDatas + installDatas' <- case sidStatus installData of + SISInstalling thread -> do + logDebug miState $ "Killing install thread for " <> unresolvedReleaseVersionToString ver + cancel thread + updateSdkInstallStatus miState installDatas ver LSP.DsError (missingSdkIdeDiagnosticMessage ver) SISDenied + _ -> pure installDatas + atomically $ putTMVar (misSdkInstallDatasVar miState) installDatas' + +-- Update sdk install data + boot pending ides for when an installation finishes (regardless of success) +onSdkInstallerFinished :: MultiIdeState -> UnresolvedReleaseVersion -> MVar T.Text -> Maybe SomeException -> IO () +onSdkInstallerFinished miState ver outputLogVar mError = do + installDatas <- atomically $ takeTMVar $ misSdkInstallDatasVar miState + let installData = getSdkInstallData ver installDatas + case mError of + Nothing -> do + let homes = sidPendingHomes installData + installDatas' = Map.delete ver installDatas + disableIde :: SubIdes -> PackageHome -> IO SubIdes + disableIde ides home = + let ides' = Map.insert home ((lookupSubIde home ides) {ideDataDisabled = IdeDataNotDisabled}) ides + in misUnsafeAddNewSubIdeAndSend miState ides' home Nothing + atomically $ putTMVar (misSdkInstallDatasVar miState) installDatas' + withIDEs_ miState $ \ides -> foldM disableIde ides homes + Just err -> do + outputLog <- takeMVar outputLogVar + let errText = failedInstallIdeDiagnosticMessage ver outputLog err + installDatas' <- updateSdkInstallStatus miState installDatas ver LSP.DsError errText (SISFailed outputLog err) + sendClient miState $ showMessage LSP.MtError errText + atomically $ putTMVar (misSdkInstallDatasVar miState) installDatas' + +-- Given a version, logging MVar and progress handler, install an sdk (blocking) +installSdk :: UnresolvedReleaseVersion -> MVar Text -> (Int -> IO ()) -> IO () +installSdk unresolvedVersion outputLogVar report = do + damlPath <- getDamlPath + cachePath <- getCachePath + -- Override the cache timeout to 5 minutes, to be sure we have a recent cache + let useCache = (mkUseCache cachePath damlPath) {overrideTimeout = Just $ CacheTimeout 300} + + version <- resolveReleaseVersionUnsafe useCache unresolvedVersion + damlConfigE <- tryConfig $ readDamlConfig damlPath + let env = InstallEnv + { options = InstallOptions + { iTargetM = Nothing + , iSnapshots = False + , iAssistant = InstallAssistant No + , iActivate = ActivateInstall False + , iForce = ForceInstall True + , iQuiet = QuietInstall False + , iSetPath = SetPath No + , iBashCompletions = BashCompletions No + , iZshCompletions = ZshCompletions No + , iInstallWithInternalVersion = InstallWithInternalVersion False + , iInstallWithCustomVersion = InstallWithCustomVersion Nothing + } + , targetVersionM = version + , assistantVersion = Nothing + , damlPath = damlPath + , useCache = useCache + , missingAssistant = False + , installingFromOutside = False + , projectPathM = Nothing + , artifactoryApiKeyM = queryArtifactoryApiKey =<< eitherToMaybe damlConfigE + , output = \str -> modifyMVar_ outputLogVar $ pure . (<> T.pack str) + , downloadProgressObserver = Just report + } + versionInstall env + +sendSdkInstallProgress :: MultiIdeState -> UnresolvedReleaseVersion -> DamlSdkInstallProgressNotificationKind -> Int -> IO () +sendSdkInstallProgress miState ver kind progress = + sendClient miState $ LSP.FromServerMess (LSP.SCustomMethod damlSdkInstallProgressMethod) $ LSP.NotMess $ + LSP.NotificationMessage "2.0" (LSP.SCustomMethod damlSdkInstallProgressMethod) $ toJSON $ DamlSdkInstallProgressNotification + { sipSdkVersion = ver + , sipKind = kind + , sipProgress = progress + } + +setupSdkInstallReporter :: MultiIdeState -> UnresolvedReleaseVersion -> IO () +setupSdkInstallReporter miState ver = sendSdkInstallProgress miState ver InstallProgressBegin 0 + +updateSdkInstallReporter :: MultiIdeState -> UnresolvedReleaseVersion -> Int -> IO () +updateSdkInstallReporter miState ver = sendSdkInstallProgress miState ver InstallProgressReport + +finishSdkInstallReporter :: MultiIdeState -> UnresolvedReleaseVersion -> IO () +finishSdkInstallReporter miState ver = sendSdkInstallProgress miState ver InstallProgressEnd 100 + +untrackPackageSdkInstall :: MultiIdeState -> PackageHome -> IO () +untrackPackageSdkInstall miState home = atomically $ modifyTMVar (misSdkInstallDatasVar miState) $ + fmap $ \installData -> installData {sidPendingHomes = Set.delete home $ sidPendingHomes installData} + +-- Unblock an ide's sdk from being installed if it was previously denied or failed. +allowIdeSdkInstall :: MultiIdeState -> PackageHome -> IO () +allowIdeSdkInstall miState home = do + ePackageSummary <- packageSummaryFromDamlYaml home + forM_ ePackageSummary $ \ps -> + atomically $ modifyTMVar (misSdkInstallDatasVar miState) $ Map.adjust (\installData -> + installData + { sidStatus = case sidStatus installData of + SISDenied -> SISCanAsk + SISFailed _ _ -> SISCanAsk + status -> status + } + ) (psReleaseVersion ps) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeCommunication.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeCommunication.hs new file mode 100644 index 000000000000..c0a016a8c560 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeCommunication.hs @@ -0,0 +1,73 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} + +module DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication ( + module DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication +) where + +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Monad +import Control.Monad.STM +import qualified Data.Aeson as Aeson +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Cli.Damlc.Command.MultiIde.Types +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import GHC.Conc (unsafeIOToSTM) +import qualified Language.LSP.Types as LSP +import System.Directory (doesFileExist) +import System.FilePath.Posix (takeDirectory) + +-- Communication logic + +-- Dangerous as does not hold the misSubIdesVar lock. If a shutdown is called whiled this is running, the message may not be sent. +unsafeSendSubIde :: SubIdeInstance -> LSP.FromClientMessage -> IO () +unsafeSendSubIde ide = atomically . unsafeSendSubIdeSTM ide + +unsafeSendSubIdeSTM :: SubIdeInstance -> LSP.FromClientMessage -> STM () +unsafeSendSubIdeSTM ide = writeTChan (ideInHandleChannel ide) . Aeson.encode + +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 + +getDirectoryIfFile :: FilePath -> IO FilePath +getDirectoryIfFile path = do + isFile <- doesFileExist path + pure $ if isFile then takeDirectory path else path + +getSourceFileHome :: MultiIdeState -> FilePath -> STM PackageHome +getSourceFileHome miState path = do + -- If the path is a file, we only care about the directory, as all files in the same directory share the same home + dirPath <- unsafeIOToSTM $ getDirectoryIfFile path + sourceFileHomes <- takeTMVar (misSourceFileHomesVar miState) + case Map.lookup dirPath sourceFileHomes of + Just home -> do + putTMVar (misSourceFileHomesVar miState) sourceFileHomes + unsafeIOToSTM $ logDebug miState $ "Found cached home for " <> path + pure home + Nothing -> do + -- Safe as repeat prints are acceptable + unsafeIOToSTM $ logDebug miState $ "No cached home for " <> path + -- Read only operation, so safe within STM + home <- unsafeIOToSTM $ fromMaybe (misDefaultPackagePath miState) <$> findHome dirPath + unsafeIOToSTM $ logDebug miState $ "File system yielded " <> unPackageHome home + putTMVar (misSourceFileHomesVar miState) $ Map.insert dirPath home sourceFileHomes + pure home + +sourceFileHomeHandleDamlFileDeleted :: MultiIdeState -> FilePath -> STM () +sourceFileHomeHandleDamlFileDeleted miState path = do + dirPath <- unsafeIOToSTM $ getDirectoryIfFile path + modifyTMVar (misSourceFileHomesVar miState) $ Map.delete dirPath + +-- When a daml.yaml changes, all files pointing to it are invalidated in the cache +sourceFileHomeHandleDamlYamlChanged :: MultiIdeState -> PackageHome -> STM () +sourceFileHomeHandleDamlYamlChanged miState home = modifyTMVar (misSourceFileHomesVar miState) $ Map.filter (/=home) diff --git a/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeManagement.hs b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeManagement.hs new file mode 100644 index 000000000000..380f1ee09f47 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/SubIdeManagement.hs @@ -0,0 +1,331 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} + +module DA.Cli.Damlc.Command.MultiIde.SubIdeManagement ( + module DA.Cli.Damlc.Command.MultiIde.SubIdeManagement, + module DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication, +) where + +import Control.Concurrent.Async (async) +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TVar +import Control.Concurrent.MVar +import Control.Exception (displayException) +import Control.Lens +import Control.Monad +import Control.Monad.STM +import DA.Cli.Damlc.Command.MultiIde.ClientCommunication +import DA.Cli.Damlc.Command.MultiIde.OpenFiles +import DA.Cli.Damlc.Command.MultiIde.Parsing +import DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication +import DA.Cli.Damlc.Command.MultiIde.Types +import DA.Cli.Damlc.Command.MultiIde.Util +import DA.Cli.Damlc.Command.MultiIde.SdkInstall +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) +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 qualified Language.LSP.Types as LSP +import System.Environment (getEnv, getEnvironment) +import System.IO.Extra +import System.Info.Extra (isWindows) +import System.Process (getPid, terminateProcess) +import System.Process.Typed ( + Process, + StreamSpec, + getStderr, + getStdin, + getStdout, + mkPipeStreamSpec, + proc, + setEnv, + setStderr, + setStdin, + setStdout, + setWorkingDir, + startProcess, + unsafeProcessHandle, + ) + +-- Spin-up logic + +-- 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 + -> 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" + + ePackageSummary <- packageSummaryFromDamlYaml home + let unCheckedIdeData = lookupSubIde home ides + + ideData <- case ePackageSummary of + Right packageSummary -> ensureIdeSdkInstalled miState (psReleaseVersion packageSummary) home unCheckedIdeData + Left _ -> pure unCheckedIdeData + + let disableIdeWithError :: T.Text -> IO SubIdes + disableIdeWithError err = do + responses <- getUnrespondedRequestsFallbackResponses miState ideData home + logDebug miState $ "Found " <> show (length responses) <> " unresponded messages, sending empty replies." + + let ideData' = ideData {ideDataDisabled = IdeDataDisabled LSP.DsError err, ideDataFailures = []} + atomically $ do + -- 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, + traverse_ (sendClientSTM miState) responses + sendPackageDiagnostic miState ideData' + pure $ Map.insert home ideData' ides + + case (ideDataMain ideData, ePackageSummary) of + -- Shortcut if the IDE already exists + (Just ide, _) -> do + logDebug miState "SubIde already exists" + forM_ mMsg $ unsafeSendSubIde ide + pure $ Map.insert home ideData ides + -- Handle disabled IDE + (Nothing, _) | ideIsDisabled ideData -> do + 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 + -- Also, package diagnostics not sent, as they will have already been sent by whatever disabled the IDE, and resending them + -- creates a loop, since diagnostics trigger a request from client + atomically $ traverse_ (sendClientSTM miState) responses + pure $ Map.insert home (ideData {ideDataFailures = []}) ides + -- Disable IDE if it errored many times + (Nothing, Right _) | ideShouldDisable ideData -> do + logDebug miState $ "SubIde failed twice within " <> show ideShouldDisableTimeout <> ", disabling SubIde" + disableIdeWithError $ "Daml IDE environment failed to start with the following error:\n" <> fromMaybe "No information" (ideGetLastFailureMessage ideData) + -- Disable IDE if daml.yaml failed to parse + (Nothing, Left err) -> do + logDebug miState "SubIde has malformed daml.yaml, disabling SubIde" + disableIdeWithError $ "daml.yaml failed to parse with the following error:\n" <> T.pack (displayException err) + -- Create the IDE + (Nothing, Right packageSummary) -> do + logInfo miState $ "Creating new SubIde for " <> unPackageHome 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. + (onceUnblocked, unblock) <- makeIOBlocker + + -- ***** -> SubIde + toSubIdeChan <- atomically newTChan + 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") . ideDataMain . lookupSubIde home <$> readTMVar (misSubIdesVar miState) + onChunks outHandle $ misSubIdeMessageHandler 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 (misInitParamsVar miState) + let ide = + SubIdeInstance + { ideInhandleAsync = toSubIde + , ideInHandle = inHandle + , ideInHandleChannel = toSubIdeChan + , ideOutHandle = outHandle + , ideOutHandleAsync = subIdeToCoord + , ideErrHandle = errHandle + , ideErrText = ideErrText + , ideErrTextAsync = ideErrTextAsync + , ideProcess = subIdeProcess + , ideHome = home + , ideMessageIdPrefix = T.pack $ show pid + , ideUnitId = psUnitId packageSummary + } + 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 misSubIdesVar 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 + + logDebug miState $ "Sending intended message to SubIde: " <> show ((\r -> (fromClientRequestMethod r, fromClientRequestLspId r)) <$> mMsg) + -- Send the intended message + forM_ mMsg $ unsafeSendSubIde ide + + pure $ Map.insert home ideData' ides + +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" : misSubIdeArgs 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 +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) || ideIsDisabled 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 +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 + untrackPackageSdkInstall miState home + 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 + , ideDataFailures = [] + , ideDataDisabled = IdeDataNotDisabled + }) home ides + Nothing -> do + pure $ Map.adjust (\ideData -> ideData {ideDataFailures = [], ideDataDisabled = IdeDataNotDisabled}) 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 -> 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 + +-- This function lives here instead of SubIdeCommunication because it can spin up new subIDEs +sendSubIdeByPath :: MultiIdeState -> FilePath -> LSP.FromClientMessage -> IO () +sendSubIdeByPath miState path msg = do + home <- atomically $ getSourceFileHome miState path + 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 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 new file mode 100644 index 000000000000..e765c7ca74ba --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Types.hs @@ -0,0 +1,420 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE GADTs #-} + +module DA.Cli.Damlc.Command.MultiIde.Types ( + module DA.Cli.Damlc.Command.MultiIde.Types +) where + +import Control.Concurrent.Async (Async) +import Control.Concurrent.STM.TChan +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TMVar +import Control.Concurrent.MVar +import Control.Exception (SomeException, displayException) +import Control.Monad (void) +import Control.Monad.STM +import DA.Daml.Project.Types (ProjectPath (..), UnresolvedReleaseVersion, unresolvedReleaseVersionToString, parseUnresolvedVersion) +import Data.Aeson +import qualified Data.ByteString as B +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, listToMaybe) +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 + -> 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 + , tamRemainingResponsePackageHomes :: [PackageHome] + -- ^ The IDES that have not yet replied to this message + , 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 (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 SubIdeInstance = SubIdeInstance + { ideInhandleAsync :: Async () + , ideInHandle :: Handle + , ideInHandleChannel :: TChan BSL.ByteString + , ideOutHandle :: Handle + , ideOutHandleAsync :: Async () + -- ^ For sending messages to that SubIde + , 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 + -- 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 + +-- When the IDE is disabled, it must have a diagnostic saying why +data IdeDataDisabled + = IdeDataNotDisabled + | IdeDataDisabled + { iddSeverity :: LSP.DiagnosticSeverity + , iddMessage :: T.Text + } + deriving (Show, Eq) + +-- 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 + , ideDataFailures :: [(UTCTime, T.Text)] + , ideDataDisabled :: IdeDataDisabled + } + +defaultSubIdeData :: PackageHome -> SubIdeData +defaultSubIdeData home = SubIdeData home Nothing Set.empty Set.empty [] IdeDataNotDisabled + +lookupSubIde :: PackageHome -> SubIdes -> SubIdeData +lookupSubIde home ides = fromMaybe (defaultSubIdeData home) $ Map.lookup home ides + +ideShouldDisableTimeout :: NominalDiffTime +ideShouldDisableTimeout = 5 + +ideShouldDisable :: SubIdeData -> Bool +ideShouldDisable (ideDataFailures -> ((t1, _):(t2, _):_)) = t1 `diffUTCTime` t2 < ideShouldDisableTimeout +ideShouldDisable _ = False + +ideIsDisabled :: SubIdeData -> Bool +ideIsDisabled (ideDataDisabled -> IdeDataDisabled {}) = True +ideIsDisabled _ = False + +ideGetLastFailureMessage :: SubIdeData -> Maybe T.Text +ideGetLastFailureMessage = fmap snd . listToMaybe . ideDataFailures + +-- 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 PackageHome SubIdeData +type SubIdesVar = TMVar SubIdes + +-- Helper functions for holding the subIdes var +withIDEsAtomic :: MultiIdeState -> (SubIdes -> STM (SubIdes, a)) -> IO a +withIDEsAtomic miState f = atomically $ do + ides <- takeTMVar $ misSubIdesVar miState + (ides', res) <- f ides + putTMVar (misSubIdesVar miState) ides' + pure res + +holdingIDEsAtomic :: MultiIdeState -> (SubIdes -> STM a) -> IO a +holdingIDEsAtomic miState f = withIDEsAtomic miState $ \ides -> (ides,) <$> f ides + +withIDEsAtomic_ :: MultiIdeState -> (SubIdes -> STM SubIdes) -> IO () +withIDEsAtomic_ miState f = void $ withIDEsAtomic miState $ fmap (, ()) . f + +withIDEs :: MultiIdeState -> (SubIdes -> IO (SubIdes, a)) -> IO a +withIDEs miState f = do + ides <- atomically $ takeTMVar $ misSubIdesVar miState + (ides', res) <- f ides + atomically $ putTMVar (misSubIdesVar 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 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 + +-- Takes unblock messages IO, subIde itself and message bytestring +-- Extracted to types to resolve cycles in dependencies +type SubIdeMessageHandler = IO () -> SubIdeInstance -> B.ByteString -> IO () + +-- Used to extract the unsafeAddNewSubIdeAndSend function to resolve dependency cycles +type UnsafeAddNewSubIdeAndSend = SubIdes -> PackageHome -> Maybe LSP.FromClientMessage -> IO SubIdes + +data SdkInstallData = SdkInstallData + { sidVersion :: UnresolvedReleaseVersion + , sidPendingHomes :: Set.Set PackageHome + , sidStatus :: SdkInstallStatus + } + deriving (Show, Eq) + +data SdkInstallStatus + = SISCanAsk + | SISAsking + | SISInstalling (Async ()) + | SISDenied + | SISFailed T.Text SomeException + +instance Eq SdkInstallStatus where + SISCanAsk == SISCanAsk = True + SISAsking == SISAsking = True + (SISInstalling thread1) == (SISInstalling thread2) = thread1 == thread2 + SISDenied == SISDenied = True + (SISFailed _ _) == (SISFailed _ _) = True + _ == _ = False + +instance Show SdkInstallStatus where + show SISCanAsk = "SISCanAsk" + show SISAsking = "SISAsking" + show (SISInstalling _) = "SISInstalling" + show SISDenied = "SISDenied" + show (SISFailed log err) = "SISFailed (" <> show log <> ") (" <> show err <> ")" + +type SdkInstallDatas = Map.Map UnresolvedReleaseVersion SdkInstallData +type SdkInstallDatasVar = TMVar SdkInstallDatas + +getSdkInstallData :: UnresolvedReleaseVersion -> SdkInstallDatas -> SdkInstallData +getSdkInstallData ver = fromMaybe (SdkInstallData ver mempty SISCanAsk) . Map.lookup ver + +data DamlSdkInstallProgressNotificationKind + = InstallProgressBegin + | InstallProgressReport + | InstallProgressEnd + +data DamlSdkInstallProgressNotification = DamlSdkInstallProgressNotification + { sipSdkVersion :: UnresolvedReleaseVersion + , sipKind :: DamlSdkInstallProgressNotificationKind + , sipProgress :: Int + } + +instance ToJSON DamlSdkInstallProgressNotification where + toJSON (DamlSdkInstallProgressNotification {..}) = object + [ "sdkVersion" .= unresolvedReleaseVersionToString sipSdkVersion + , "kind" .= case sipKind of + InstallProgressBegin -> "begin" :: T.Text + InstallProgressReport -> "report" + InstallProgressEnd -> "end" + , "progress" .= sipProgress + ] + +damlSdkInstallProgressMethod :: T.Text +damlSdkInstallProgressMethod = "daml/sdkInstallProgress" + +newtype DamlSdkInstallCancelNotification = DamlSdkInstallCancelNotification + { sicSdkVersion :: UnresolvedReleaseVersion + } + +instance FromJSON DamlSdkInstallCancelNotification where + parseJSON = withObject "DamlSdkInstallCancelNotification" $ \v -> do + sdkVersionStr <- v .: "sdkVersion" + either (fail . displayException) (pure . DamlSdkInstallCancelNotification) $ parseUnresolvedVersion sdkVersionStr + +damlSdkInstallCancelMethod :: T.Text +damlSdkInstallCancelMethod = "daml/sdkInstallCancel" + +data MultiIdeState = MultiIdeState + { misFromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient + -- ^ The client will track its own IDs to ensure they're unique, so no worries about collisions + , misFromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer + -- ^ We will prefix LspIds before they get here based on their SubIde messageIdPrefix, to avoid collisions + , misSubIdesVar :: SubIdesVar + , misInitParamsVar :: InitParamsVar + , misToClientChan :: TChan BSL.ByteString + , misMultiPackageMappingVar :: MultiPackageYamlMappingVar + , misDarDependentPackagesVar :: DarDependentPackagesVar + , misLogger :: Logger.Handle IO + , misMultiPackageHome :: FilePath + , misDefaultPackagePath :: PackageHome + , misSourceFileHomesVar :: SourceFileHomesVar + , misSubIdeArgs :: [String] + , misSubIdeMessageHandler :: SubIdeMessageHandler + , misUnsafeAddNewSubIdeAndSend :: UnsafeAddNewSubIdeAndSend + , misSdkInstallDatasVar :: SdkInstallDatasVar + } + +logError :: MultiIdeState -> String -> IO () +logError miState msg = Logger.logError (misLogger miState) (T.pack msg) + +logWarning :: MultiIdeState -> String -> IO () +logWarning miState msg = Logger.logWarning (misLogger miState) (T.pack msg) + +logInfo :: MultiIdeState -> String -> IO () +logInfo miState msg = Logger.logInfo (misLogger miState) (T.pack msg) + +logDebug :: MultiIdeState -> String -> IO () +logDebug miState msg = Logger.logDebug (misLogger miState) (T.pack msg) + +newMultiIdeState + :: FilePath + -> PackageHome + -> Logger.Priority + -> [String] + -> (MultiIdeState -> SubIdeMessageHandler) + -> (MultiIdeState -> UnsafeAddNewSubIdeAndSend) + -> IO MultiIdeState +newMultiIdeState misMultiPackageHome misDefaultPackagePath logThreshold misSubIdeArgs subIdeMessageHandler unsafeAddNewSubIdeAndSend = do + (misFromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient) <- newTVarIO IM.emptyIxMap + (misFromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer) <- newTVarIO IM.emptyIxMap + misSubIdesVar <- newTMVarIO @SubIdes mempty + misInitParamsVar <- newEmptyMVar @InitParams + misToClientChan <- atomically newTChan + misMultiPackageMappingVar <- newTMVarIO @MultiPackageYamlMapping mempty + misDarDependentPackagesVar <- newTMVarIO @DarDependentPackages mempty + misSourceFileHomesVar <- newTMVarIO @SourceFileHomes mempty + misLogger <- Logger.newStderrLogger logThreshold "Multi-IDE" + misSdkInstallDatasVar <- newTMVarIO @SdkInstallDatas mempty + let miState = + MultiIdeState + { misSubIdeMessageHandler = subIdeMessageHandler miState + , misUnsafeAddNewSubIdeAndSend = unsafeAddNewSubIdeAndSend miState + , .. + } + pure miState + +-- Forwarding + +{- +Types of behaviour we want: + +Regularly handling by a single IDE - works for requests and notifications + e.g. TextDocumentDidOpen +Ignore it + e.g. Initialize +Forward a notification to all IDEs + e.g. workspace folders changed, exit +Forward a request to all IDEs and somehow combine the result + e.g. + symbol lookup -> combine monoidically + shutdown -> response is empty, so identity after all responses + This is the hard one as we need some way to define the combination logic + which will ideally wait for all IDEs to reply to the request and apply this function over the (possibly failing) result + This mostly covers FromClient requests that we can't pull a filepath from + + Previously thought we would need this more, now we only really use it for shutdown - ensuring all SubIdes shutdown before replying. + We'll keep it in though since we'll likely get more capabilities supported when we upgrade ghc/move to HLS +-} + +-- TODO: Consider splitting this into one data type for request and one for notification +-- rather than reusing the Single constructor over both and restricting via types +data ForwardingBehaviour (m :: LSP.Method 'LSP.FromClient t) where + Single + :: forall t (m :: LSP.Method 'LSP.FromClient t) + . FilePath + -> ForwardingBehaviour m + AllRequest + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . ResponseCombiner m + -> ForwardingBehaviour m + AllNotification + :: ForwardingBehaviour (m :: LSP.Method 'LSP.FromClient 'LSP.Notification) + +-- Akin to ClientNotOrReq tagged with ForwardingBehaviour, and CustomMethod realised to req/not +data Forwarding (m :: LSP.Method 'LSP.FromClient t) where + ForwardRequest + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request) + . LSP.RequestMessage m + -> ForwardingBehaviour m + -> Forwarding m + ForwardNotification + :: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Notification) + . LSP.NotificationMessage m + -> ForwardingBehaviour m + -> Forwarding m + ExplicitHandler + :: ( (LSP.FromServerMessage -> IO ()) + -> (FilePath -> LSP.FromClientMessage -> IO ()) + -> IO () + ) + -> Forwarding (m :: LSP.Method 'LSP.FromClient t) + +type ResponseCombiner (m :: LSP.Method 'LSP.FromClient 'LSP.Request) = + [(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 + } + +data PackageSummary = PackageSummary + { psUnitId :: UnitId + , psDeps :: [DarFile] + , psReleaseVersion :: UnresolvedReleaseVersion + } 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 new file mode 100644 index 000000000000..13ad43afce16 --- /dev/null +++ b/sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Util.hs @@ -0,0 +1,334 @@ +-- 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 GADTs #-} + +module DA.Cli.Damlc.Command.MultiIde.Util ( + module DA.Cli.Damlc.Command.MultiIde.Util +) where + +import Control.Concurrent.Async (AsyncCancelled (..)) +import Control.Concurrent.MVar +import Control.Concurrent.STM.TMVar +import Control.Exception (SomeException, fromException, handle, try, tryJust) +import Control.Lens ((^.)) +import Control.Monad (void) +import Control.Monad.STM +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 (..), parseUnresolvedVersion) +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, withCurrentDirectory, canonicalizePath) +import qualified System.FilePath as NativeFilePath +import System.FilePath.Posix (joinDrive, takeDirectory, takeExtension) +import System.IO (Handle, hClose, hFlush) +import Text.Read (readMaybe) + +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 = modifyTMVarM var (pure . f) + +modifyTMVarM :: TMVar a -> (a -> STM a) -> STM () +modifyTMVarM var f = do + x <- takeTMVar var + x' <- f x + putTMVar var x' + +-- Taken directly from the Initialize response +initializeResult :: LSP.InitializeResult +initializeResult = LSP.InitializeResult + { _capabilities = LSP.ServerCapabilities + { _textDocumentSync = Just $ LSP.InL $ LSP.TextDocumentSyncOptions + { _openClose = Just True + , _change = Just LSP.TdSyncIncremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (LSP.InR (LSP.SaveOptions {_includeText = Nothing})) + } + , _hoverProvider = true + , _completionProvider = Just $ LSP.CompletionOptions + { _workDoneProgress = Nothing + , _triggerCharacters = Nothing + , _allCommitCharacters = Nothing + , _resolveProvider = Just False + } + , _signatureHelpProvider = Nothing + , _declarationProvider = false + , _definitionProvider = true + , _typeDefinitionProvider = false + , _implementationProvider = false + , _referencesProvider = false + , _documentHighlightProvider = false + , _documentSymbolProvider = true + , _codeActionProvider = true + , _codeLensProvider = Just (LSP.CodeLensOptions {_workDoneProgress = Just False, _resolveProvider = Just False}) + , _documentLinkProvider = Nothing + , _colorProvider = false + , _documentFormattingProvider = false + , _documentRangeFormattingProvider = false + , _documentOnTypeFormattingProvider = Nothing + , _renameProvider = false + , _foldingRangeProvider = false + , _executeCommandProvider = Just (LSP.ExecuteCommandOptions {_workDoneProgress = Nothing, _commands = LSP.List ["typesignature.add"]}) + , _selectionRangeProvider = false + , _callHierarchyProvider = false + , _semanticTokensProvider = Just $ LSP.InR $ LSP.SemanticTokensRegistrationOptions + { _documentSelector = Nothing + , _workDoneProgress = Nothing + , _legend = LSP.SemanticTokensLegend + { _tokenTypes = LSP.List + [ LSP.SttType + , LSP.SttClass + , LSP.SttEnum + , LSP.SttInterface + , LSP.SttStruct + , LSP.SttTypeParameter + , LSP.SttParameter + , LSP.SttVariable + , LSP.SttProperty + , LSP.SttEnumMember + , LSP.SttEvent + , LSP.SttFunction + , LSP.SttMethod + , LSP.SttMacro + , LSP.SttKeyword + , LSP.SttModifier + , LSP.SttComment + , LSP.SttString + , LSP.SttNumber + , LSP.SttRegexp + , LSP.SttOperator + ] + , _tokenModifiers = LSP.List + [ LSP.StmDeclaration + , LSP.StmDefinition + , LSP.StmReadonly + , LSP.StmStatic + , LSP.StmDeprecated + , LSP.StmAbstract + , LSP.StmAsync + , LSP.StmModification + , LSP.StmDocumentation + , LSP.StmDefaultLibrary + ] + } + + , _range = Nothing + , _full = Nothing + , _id = Nothing + } + , _workspaceSymbolProvider = Just False + , _workspace = Just $ LSP.WorkspaceServerCapabilities + { _workspaceFolders = + Just (LSP.WorkspaceFoldersServerCapabilities {_supported = Just True, _changeNotifications = Just (LSP.InR True)}) + } + , _experimental = Nothing + } + , _serverInfo = Nothing + } + where + 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" + } + +closeFileNotification :: DamlFile -> LSP.FromClientMessage +closeFileNotification path = LSP.FromClientMess LSP.STextDocumentDidClose LSP.NotificationMessage + {_method = LSP.STextDocumentDidClose + , _params = LSP.DidCloseTextDocumentParams $ LSP.TextDocumentIdentifier $ + LSP.filePathToUri $ unDamlFile path + , _jsonrpc = "2.0" + } + +registerFileWatchersMessage :: LSP.FromServerMessage +registerFileWatchersMessage = + LSP.FromServerMess LSP.SClientRegisterCapability $ + 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 PackageHome) +findHome path = do + exists <- doesDirectoryExist path + if exists then aux path else aux (takeDirectory path) + where + aux :: FilePath -> IO (Maybe PackageHome) + aux path = do + hasDamlYaml <- elem projectConfigName <$> listDirectory path + if hasDamlYaml + then pure $ Just $ PackageHome path + else do + let newPath = takeDirectory path + if path == newPath + then pure Nothing + else aux newPath + +packageSummaryFromDamlYaml :: PackageHome -> IO (Either ConfigError PackageSummary) +packageSummaryFromDamlYaml 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 + releaseVersion <- except $ queryProjectConfigRequired ["sdk-version"] project + -- Default error gives too much information, e.g. `Invalid SDK version "2.8.e": Failed reading: takeWhile1` + -- Just saying its invalid is enough + unresolvedReleaseVersion <- except $ first (const $ ConfigFieldInvalid "project" ["sdk-version"] $ "Invalid Daml SDK version: " <> T.unpack releaseVersion) + $ parseUnresolvedVersion releaseVersion + pure PackageSummary + { psUnitId = UnitId $ name <> "-" <> version + , psDeps = DarFile . toPosixFilePath <$> canonDeps + , psReleaseVersion = unresolvedReleaseVersion + } + +-- 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 :: LSP.DiagnosticSeverity -> String -> FilePath -> LSP.FromServerMessage +fullFileDiagnostic severity 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 severity + , _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 [] + +showMessageRequest :: LSP.LspId 'LSP.WindowShowMessageRequest -> LSP.MessageType -> T.Text -> [T.Text] -> LSP.FromServerMessage +showMessageRequest lspId messageType message options = LSP.FromServerMess LSP.SWindowShowMessageRequest $ + LSP.RequestMessage "2.0" lspId LSP.SWindowShowMessageRequest $ LSP.ShowMessageRequestParams messageType message $ + Just $ LSP.MessageActionItem <$> options + +showMessage :: LSP.MessageType -> T.Text -> LSP.FromServerMessage +showMessage messageType message = LSP.FromServerMess LSP.SWindowShowMessage $ + LSP.NotificationMessage "2.0" LSP.SWindowShowMessage $ LSP.ShowMessageParams messageType message + +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 "\\" "/" + +-- Attempts to exact the percent amount from a string containing strings like 30% +extractPercentFromText :: T.Text -> Maybe Integer +extractPercentFromText = readMaybe . T.unpack . T.dropWhile (==' ') . T.takeEnd 3 . T.dropEnd 1 . fst . T.breakOnEnd "%" + +-- try @SomeException that doesn't catch AsyncCancelled exceptions +tryForwardAsync :: IO a -> IO (Either SomeException a) +tryForwardAsync = tryJust @SomeException $ \case + (fromException -> Just AsyncCancelled) -> Nothing + e -> Just e diff --git a/sdk/daml-assistant/exe/DA/Daml/Assistant.hs b/sdk/daml-assistant/exe/DA/Daml/Assistant.hs index 9a77fbb5eba6..1d581dacec14 100644 --- a/sdk/daml-assistant/exe/DA/Daml/Assistant.hs +++ b/sdk/daml-assistant/exe/DA/Daml/Assistant.hs @@ -177,6 +177,7 @@ autoInstall env@Env{..} = do -- and we don't want to mess up the other command's -- output / have the install messages be gobbled -- up by a pipe. + , downloadProgressObserver = Nothing } versionInstall installEnv pure env { envSdkPath = Just (defaultSdkPathUnresolved envDamlPath sdkVersion) } diff --git a/sdk/daml-assistant/src/DA/Daml/Assistant/Install.hs b/sdk/daml-assistant/src/DA/Daml/Assistant/Install.hs index 9bfa4acf8a3b..a455ff9472d8 100644 --- a/sdk/daml-assistant/src/DA/Daml/Assistant/Install.hs +++ b/sdk/daml-assistant/src/DA/Daml/Assistant/Install.hs @@ -16,6 +16,7 @@ module DA.Daml.Assistant.Install , pattern RawInstallTarget_Project ) where +import Control.Concurrent.MVar (newMVar, modifyMVar_) import DA.Directory import DA.Daml.Assistant.Types import DA.Daml.Assistant.Util @@ -94,6 +95,8 @@ data InstallEnvF a = InstallEnv -- ^ Artifactoyr API key used to fetch SDK EE tarball. , output :: String -> IO () -- ^ output an informative message + , downloadProgressObserver :: Maybe (Int -> IO ()) + -- ^ optional alternative handler for http download progresss } instance Functor InstallEnvF where @@ -407,11 +410,25 @@ httpInstall env@InstallEnv{targetVersionM = releaseVersion, ..} = do observeProgress :: MonadResource m => Int -> ConduitT BS.ByteString BS.ByteString m () - observeProgress totalSize = do - pb <- liftIO $ newProgressBar defStyle 10 (Progress 0 totalSize ()) - List.mapM $ \bs -> do - liftIO $ incProgress pb (BS.length bs) - pure bs + observeProgress totalSize = + case downloadProgressObserver of + -- When no explicit observer, use the progressBar library (which prints to stderr and cannot not use `output`) + Nothing -> do + pb <- liftIO $ newProgressBar defStyle 10 (Progress 0 totalSize ()) + List.mapM $ \bs -> do + liftIO $ incProgress pb (BS.length bs) + pure bs + -- When an observer is given, track state and call observer whenever percent int changes + Just observer -> do + progressVar <- liftIO $ newMVar (0, 0) + List.mapM $ \bs -> do + liftIO $ modifyMVar_ progressVar $ \(lastProgress, lastReportedPercent) -> do + let newProgress = lastProgress + BS.length bs + newPercent = (newProgress * 100) `div` totalSize + if newPercent - lastReportedPercent > 0 + then (newProgress, newPercent) <$ observer newPercent + else pure (newProgress, lastReportedPercent) + pure bs -- | Perform an action with a file lock from DAML_HOME/sdk/.lock -- This function blocks until the lock has been obtained. @@ -543,6 +560,7 @@ install options damlPath useCache projectPathM assistantVersion = targetVersionM = () -- determined later output = putStrLn -- Output install messages to stdout. artifactoryApiKeyM = DAVersion.queryArtifactoryApiKey =<< eitherToMaybe damlConfigE + downloadProgressObserver = Nothing env = InstallEnv {..} warnAboutAnyInstallFlags command = do when (unInstallWithInternalVersion (iInstallWithInternalVersion options)) $ diff --git a/sdk/release/sdk-config.yaml.tmpl b/sdk/release/sdk-config.yaml.tmpl index 8119e68d2fbe..787a95a60cad 100644 --- a/sdk/release/sdk-config.yaml.tmpl +++ b/sdk/release/sdk-config.yaml.tmpl @@ -91,6 +91,9 @@ commands: path: daml-helper/daml-helper args: ["run-jar", "--logback-config=daml-sdk/trigger-logback.xml", "daml-sdk/daml-sdk.jar", "trigger"] desc: "Run a Daml trigger" +- name: multi-ide + path: damlc/damlc + args: ["lax", "multi-ide"] - name: script path: daml-helper/daml-helper args: ["run-jar", "--logback-config=daml-sdk/script-logback.xml", "daml-sdk/daml-sdk.jar", "script"]