mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-19 16:57:40 +03:00
Split up MultiIde.hs into many files (#19198)
* Split up MultiIde.hs into many files * Further split SubIde
This commit is contained in:
Samuel Williams
GitHub
parent
b44823df67
commit
9c6460827e
@ -1,876 +1,43 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde (runMultiIde) where
|
||||
|
||||
import qualified "zip-archive" Codec.Archive.Zip as Zip
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (async, cancel, pollSTM)
|
||||
import Control.Concurrent.STM.TChan
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception(SomeException, displayException, fromException, try)
|
||||
import Control.Lens
|
||||
import Control.Exception(SomeException, fromException)
|
||||
import Control.Monad
|
||||
import Control.Monad.STM
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.State.Strict (StateT, runStateT, gets, modify')
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSLC
|
||||
import DA.Cli.Damlc.Command.MultiIde.Forwarding
|
||||
import DA.Cli.Damlc.Command.MultiIde.Prefixing
|
||||
import DA.Cli.Damlc.Command.MultiIde.Util
|
||||
import DA.Cli.Damlc.Command.MultiIde.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.DarDependencies (resolveSourceLocation, unpackDar, unpackedDarsLocation)
|
||||
import DA.Daml.LanguageServer.SplitGotoDefinition
|
||||
import DA.Daml.LF.Reader (DalfManifest(..), readDalfManifest)
|
||||
import DA.Daml.Package.Config (MultiPackageConfigFields(..), findMultiPackageConfig, withMultiPackageConfig)
|
||||
import DA.Daml.Project.Consts (projectConfigName)
|
||||
import DA.Daml.Project.Types (ProjectPath (..))
|
||||
import DA.Cli.Damlc.Command.MultiIde.Util
|
||||
import qualified DA.Service.Logger as Logger
|
||||
import Data.Either (lefts)
|
||||
import Data.Either.Extra (eitherToMaybe)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.List (find, isInfixOf, isPrefixOf)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, maybeToList)
|
||||
import Data.Maybe (catMaybes, maybeToList)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Extended as TE
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import GHC.Conc (unsafeIOToSTM)
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import qualified Language.LSP.Types.Lens as LSP
|
||||
import qualified SdkVersion.Class
|
||||
import System.Directory (doesFileExist, getCurrentDirectory)
|
||||
import System.Environment (getEnv, getEnvironment)
|
||||
import System.Directory (getCurrentDirectory)
|
||||
import System.Exit (exitSuccess)
|
||||
import System.FilePath.Posix (takeDirectory, takeExtension, takeFileName, (</>))
|
||||
import System.FilePath.Posix ((</>))
|
||||
import System.IO.Extra
|
||||
import System.Info.Extra (isWindows)
|
||||
import System.Process (getPid, terminateProcess)
|
||||
import System.Process.Typed (
|
||||
ExitCode (..),
|
||||
Process,
|
||||
StreamSpec,
|
||||
getExitCodeSTM,
|
||||
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"
|
||||
|
||||
let ideData = lookupSubIde home ides
|
||||
case ideDataMain ideData of
|
||||
Just ide -> do
|
||||
logDebug miState "SubIDE already exists"
|
||||
forM_ mMsg $ unsafeSendSubIDE ide
|
||||
pure ides
|
||||
Nothing | ideShouldDisable ideData || ideDataDisabled ideData -> do
|
||||
when (ideShouldDisable ideData) $ logDebug miState $ "SubIDE failed twice within " <> show ideShouldDisableTimeout <> ", disabling SubIDE"
|
||||
|
||||
responses <- getUnrespondedRequestsFallbackResponses miState ideData home
|
||||
logDebug miState $ "Found " <> show (length responses) <> " unresponded messages, sending empty replies."
|
||||
|
||||
-- Doesn't include mMsg, as if it was request, it'll already be in the tracker, so a reply for it will be in `responses`
|
||||
-- As such, we cannot send this on every failed message,
|
||||
let ideData' = ideData {ideDataDisabled = True, ideDataFailTimes = []}
|
||||
-- Only add diagnostic messages for first fail to start.
|
||||
-- Diagnostic messages trigger the client to send a codeAction request, which would create an infinite loop if we sent
|
||||
-- diagnostics with its reply
|
||||
messages = responses <> if ideShouldDisable ideData then disableIdeDiagnosticMessages ideData else []
|
||||
|
||||
atomically $ traverse_ (sendClientSTM miState) messages
|
||||
pure $ Map.insert home ideData' ides
|
||||
Nothing -> do
|
||||
logInfo miState $ "Creating new SubIDE for " <> unPackageHome home
|
||||
traverse_ (sendClient miState) $ clearIdeDiagnosticMessages ideData
|
||||
|
||||
unitId <- either (\cErr -> error $ "Failed to get unit ID from daml.yaml: " <> show cErr) fst <$> unitIdAndDepsFromDamlYaml 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 (subIDEsVar miState)
|
||||
onChunks outHandle $ subIDEMessageHandler miState unblock ide
|
||||
|
||||
pid <- fromMaybe (error "SubIDE has no PID") <$> getPid (unsafeProcessHandle subIdeProcess)
|
||||
|
||||
ideErrTextAsync <- async $
|
||||
let go = do
|
||||
text <- T.hGetChunk errHandle
|
||||
unless (text == "") $ do
|
||||
atomically $ modifyTVar' ideErrText (<> text)
|
||||
logDebug miState $ "[SubIDE " <> show pid <> "] " <> T.unpack text
|
||||
go
|
||||
in go
|
||||
|
||||
mInitParams <- tryReadMVar (initParamsVar miState)
|
||||
let 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 = unitId
|
||||
}
|
||||
ideData' = ideData {ideDataMain = Just ide}
|
||||
!initParams = fromMaybe (error "Attempted to create a SubIDE before initialization!") mInitParams
|
||||
initMsg = initializeRequest initParams ide
|
||||
|
||||
-- Must happen before the initialize message is added, else it'll delete that
|
||||
unrespondedRequests <- getUnrespondedRequestsToResend miState ideData home
|
||||
|
||||
logDebug miState "Sending init message to SubIDE"
|
||||
putSingleFromClientMessage miState home initMsg
|
||||
unsafeSendSubIDE ide initMsg
|
||||
|
||||
-- Dangerous calls are okay here because we're already holding the subIDEsVar lock
|
||||
-- Send the open file notifications
|
||||
logDebug miState "Sending open files messages to SubIDE"
|
||||
forM_ (ideDataOpenFiles ideData') $ \path -> do
|
||||
content <- TE.readFileUtf8 $ unDamlFile path
|
||||
unsafeSendSubIDE ide $ openFileNotification path content
|
||||
|
||||
|
||||
-- Resend all pending requests
|
||||
-- No need for re-prefixing or anything like that, messages are stored with the prefixes they need
|
||||
-- Note that we want to remove the message we're sending from this list, to not send it twice
|
||||
let mMsgLspId = mMsg >>= fromClientRequestLspId
|
||||
requestsToResend = filter (\req -> fromClientRequestLspId req /= mMsgLspId) unrespondedRequests
|
||||
logDebug miState $ "Found " <> show (length requestsToResend) <> " unresponded messages, resending:\n"
|
||||
<> show (fmap (\r -> (fromClientRequestMethod r, fromClientRequestLspId r)) requestsToResend)
|
||||
|
||||
traverse_ (unsafeSendSubIDE ide) requestsToResend
|
||||
|
||||
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
|
||||
|
||||
disableIdeDiagnosticMessages :: SubIDEData -> [LSP.FromServerMessage]
|
||||
disableIdeDiagnosticMessages ideData =
|
||||
fullFileDiagnostic
|
||||
( "Daml IDE environment failed to start with the following error:\n"
|
||||
<> fromMaybe "No information" (ideDataLastError ideData)
|
||||
)
|
||||
<$> ((unPackageHome (ideDataHome ideData) </> "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData))
|
||||
|
||||
clearIdeDiagnosticMessages :: SubIDEData -> [LSP.FromServerMessage]
|
||||
clearIdeDiagnosticMessages ideData =
|
||||
clearDiagnostics <$> ((unPackageHome (ideDataHome ideData) </> "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData))
|
||||
|
||||
runSubProc :: MultiIdeState -> PackageHome -> IO (Process Handle Handle Handle)
|
||||
runSubProc miState home = do
|
||||
assistantPath <- getEnv "DAML_ASSISTANT"
|
||||
-- Need to remove some variables so the sub-assistant will pick them up from the working dir/daml.yaml
|
||||
assistantEnv <- filter (flip notElem ["DAML_PROJECT", "DAML_SDK_VERSION", "DAML_SDK"] . fst) <$> getEnvironment
|
||||
|
||||
startProcess $
|
||||
proc assistantPath ("ide" : subIdeArgs miState) &
|
||||
setStdin createPipeNoClose &
|
||||
setStdout createPipeNoClose &
|
||||
setStderr createPipeNoClose &
|
||||
setWorkingDir (unPackageHome home) &
|
||||
setEnv assistantEnv
|
||||
where
|
||||
createPipeNoClose :: StreamSpec streamType Handle
|
||||
createPipeNoClose = mkPipeStreamSpec $ \_ h -> pure (h, pure ())
|
||||
|
||||
-- Spin-down logic
|
||||
rebootIdeByHome :: MultiIdeState -> PackageHome -> IO ()
|
||||
rebootIdeByHome miState home = withIDEs_ miState $ \ides -> do
|
||||
ides' <- unsafeShutdownIdeByHome miState ides home
|
||||
unsafeAddNewSubIDEAndSend miState ides' home Nothing
|
||||
|
||||
-- Version of rebootIdeByHome that only spins up IDEs that were either active, or disabled.
|
||||
-- Does not spin up IDEs that were naturally shutdown/never started
|
||||
lenientRebootIdeByHome :: MultiIdeState -> PackageHome -> IO ()
|
||||
lenientRebootIdeByHome miState home = withIDEs_ miState $ \ides -> do
|
||||
let ideData = lookupSubIde home ides
|
||||
shouldBoot = isJust (ideDataMain ideData) || ideDataDisabled ideData
|
||||
ides' <- unsafeShutdownIdeByHome miState ides home
|
||||
if shouldBoot
|
||||
then unsafeAddNewSubIDEAndSend miState ides' home Nothing
|
||||
else pure ides'
|
||||
|
||||
-- Checks if a shutdown message LspId originated from the multi-ide coordinator
|
||||
isCoordinatorShutdownLspId :: LSP.LspId 'LSP.Shutdown -> Bool
|
||||
isCoordinatorShutdownLspId (LSP.IdString str) = "-shutdown" `T.isSuffixOf` str
|
||||
isCoordinatorShutdownLspId _ = False
|
||||
|
||||
-- Sends a shutdown message and moves SubIDEInstance to `ideDataClosing`, disallowing any further client messages to be sent to the subIDE
|
||||
-- given queue nature of TChan, all other pending messages will be sent first before handling shutdown
|
||||
shutdownIdeByHome :: MultiIdeState -> PackageHome -> IO ()
|
||||
shutdownIdeByHome miState home = withIDEs_ miState $ \ides -> unsafeShutdownIdeByHome miState ides home
|
||||
|
||||
-- Unsafe as does not acquire SubIDEsVar, instead simply transforms it
|
||||
unsafeShutdownIdeByHome :: MultiIdeState -> SubIDEs -> PackageHome -> IO SubIDEs
|
||||
unsafeShutdownIdeByHome miState ides home = do
|
||||
let ideData = lookupSubIde home ides
|
||||
case ideDataMain ideData of
|
||||
Just ide -> do
|
||||
let shutdownId = LSP.IdString $ ideMessageIdPrefix ide <> "-shutdown"
|
||||
shutdownMsg :: LSP.FromClientMessage
|
||||
shutdownMsg = LSP.FromClientMess LSP.SShutdown LSP.RequestMessage
|
||||
{ _id = shutdownId
|
||||
, _method = LSP.SShutdown
|
||||
, _params = LSP.Empty
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
|
||||
logDebug miState $ "Sending shutdown message to " <> unPackageHome (ideDataHome ideData)
|
||||
|
||||
putSingleFromClientMessage miState home shutdownMsg
|
||||
unsafeSendSubIDE ide shutdownMsg
|
||||
pure $ Map.adjust (\ideData' -> ideData'
|
||||
{ ideDataMain = Nothing
|
||||
, ideDataClosing = Set.insert ide $ ideDataClosing ideData
|
||||
, ideDataFailTimes = []
|
||||
, ideDataDisabled = False
|
||||
}) home ides
|
||||
Nothing ->
|
||||
pure $ Map.adjust (\ideData -> ideData {ideDataFailTimes = [], ideDataDisabled = False}) home ides
|
||||
|
||||
-- To be called once we receive the Shutdown response
|
||||
-- Safe to assume that the sending channel is empty, so we can end the thread and send the final notification directly on the handle
|
||||
handleExit :: MultiIdeState -> SubIDEInstance -> IO ()
|
||||
handleExit miState ide =
|
||||
if isWindows
|
||||
then do
|
||||
-- On windows, ghc-ide doesn't close correctly on exit messages (even terminating the process leaves subprocesses behind)
|
||||
-- Instead, we close the handle its listening on, and terminate the process.
|
||||
logDebug miState $ "(windows) Closing handle and terminating " <> unPackageHome (ideHome ide)
|
||||
hTryClose $ ideInHandle ide
|
||||
terminateProcess $ unsafeProcessHandle $ ideProcess ide
|
||||
else do
|
||||
let (exitMsg :: LSP.FromClientMessage) = LSP.FromClientMess LSP.SExit LSP.NotificationMessage
|
||||
{ _method = LSP.SExit
|
||||
, _params = LSP.Empty
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
logDebug miState $ "Sending exit message to " <> unPackageHome (ideHome ide)
|
||||
-- This will cause the subIDE process to exit
|
||||
-- Able to be unsafe as no other messages can use this IDE once it has been shutdown
|
||||
unsafeSendSubIDE ide exitMsg
|
||||
|
||||
-- Communication logic
|
||||
|
||||
-- Dangerous as does not hold the subIDEsVar lock. If a shutdown is called whiled this is running, the message may not be sent.
|
||||
unsafeSendSubIDE :: SubIDEInstance -> LSP.FromClientMessage -> IO ()
|
||||
unsafeSendSubIDE ide = atomically . unsafeSendSubIDESTM ide
|
||||
|
||||
unsafeSendSubIDESTM :: SubIDEInstance -> LSP.FromClientMessage -> STM ()
|
||||
unsafeSendSubIDESTM ide = writeTChan (ideInHandleChannel ide) . Aeson.encode
|
||||
|
||||
sendClientSTM :: MultiIdeState -> LSP.FromServerMessage -> STM ()
|
||||
sendClientSTM miState = writeTChan (toClientChan miState) . Aeson.encode
|
||||
|
||||
sendClient :: MultiIdeState -> LSP.FromServerMessage -> IO ()
|
||||
sendClient miState = atomically . sendClientSTM miState
|
||||
|
||||
-- Sends a message to the client, putting it at the start of the queue to be sent first
|
||||
sendClientFirst :: MultiIdeState -> LSP.FromServerMessage -> IO ()
|
||||
sendClientFirst miState = atomically . unGetTChan (toClientChan miState) . Aeson.encode
|
||||
|
||||
sendAllSubIDEs :: MultiIdeState -> LSP.FromClientMessage -> IO [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 (sourceFileHomesVar miState)
|
||||
case Map.lookup dirPath sourceFileHomes of
|
||||
Just home -> do
|
||||
putTMVar (sourceFileHomesVar 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 (defaultPackagePath miState) <$> findHome dirPath
|
||||
unsafeIOToSTM $ logDebug miState $ "File system yielded " <> unPackageHome home
|
||||
putTMVar (sourceFileHomesVar miState) $ Map.insert dirPath home sourceFileHomes
|
||||
pure home
|
||||
|
||||
sourceFileHomeHandleDamlFileDeleted :: MultiIdeState -> FilePath -> STM ()
|
||||
sourceFileHomeHandleDamlFileDeleted miState path = do
|
||||
dirPath <- unsafeIOToSTM $ getDirectoryIfFile path
|
||||
modifyTMVar (sourceFileHomesVar 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 (sourceFileHomesVar miState) $ Map.filter (/=home)
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
onOpenFiles :: MultiIdeState -> PackageHome -> (Set.Set DamlFile -> Set.Set DamlFile) -> STM ()
|
||||
onOpenFiles miState home f = modifyTMVarM (subIDEsVar miState) $ \subIdes -> do
|
||||
let ideData = lookupSubIde home subIdes
|
||||
ideData' = ideData {ideDataOpenFiles = f $ ideDataOpenFiles ideData}
|
||||
when (ideDataDisabled ideData') $ traverse_ (sendClientSTM miState) $ disableIdeDiagnosticMessages ideData'
|
||||
pure $ Map.insert home ideData' subIdes
|
||||
|
||||
addOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM ()
|
||||
addOpenFile miState home file = do
|
||||
unsafeIOToSTM $ logInfo miState $ "Added open file " <> unDamlFile file <> " to " <> unPackageHome home
|
||||
onOpenFiles miState home $ Set.insert file
|
||||
|
||||
removeOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM ()
|
||||
removeOpenFile miState home file = do
|
||||
unsafeIOToSTM $ logInfo miState $ "Removed open file " <> unDamlFile file <> " from " <> unPackageHome home
|
||||
onOpenFiles miState home $ Set.delete file
|
||||
|
||||
-- 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
|
||||
when (ideDataDisabled newHomeIdeData') $ traverse_ (sendClientSTM miState) $ disableIdeDiagnosticMessages 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 == defaultPackagePath 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'
|
||||
|
||||
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 (fromClientMethodTrackerVar miState) (ideHome ide) val
|
||||
|
||||
-- Adds the various prefixes needed for from server messages to not clash with those from other IDEs
|
||||
let prefixer :: LSP.FromServerMessage -> LSP.FromServerMessage
|
||||
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"
|
||||
-- Dangerous call here is acceptable as this only happens while the ide is booting, before unblocking
|
||||
unsafeSendSubIDE ide $ LSP.FromClientMess LSP.SInitialized $ LSP.NotificationMessage "2.0" LSP.SInitialized (Just LSP.InitializedParams)
|
||||
unblock
|
||||
LSP.FromServerRsp LSP.SShutdown (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 $ multiPackageMappingVar miState)
|
||||
case mSourceLocation of
|
||||
-- Didn't find a home for this name, we do not know where this is defined, so give back the (known to be wrong)
|
||||
-- .daml data-dependency path
|
||||
-- This is the worst case, we'll later add logic here to unpack and spinup an SubIDE for the read-only dependency
|
||||
Nothing -> replyLocations [loc]
|
||||
-- We found a daml.yaml for this definition, send the getDefinitionByName request to its SubIDE
|
||||
Just 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 (fromServerMethodTrackerVar 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 (initParamsVar 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
|
||||
let LSP.RequestMessage {_id, _method} = registerFileWatchersMessage
|
||||
putReqMethodSingleFromServerCoordinator (fromServerMethodTrackerVar miState) _id _method
|
||||
|
||||
sendClient miState $ LSP.FromServerMess _method registerFileWatchersMessage
|
||||
|
||||
LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel notif -> do
|
||||
let (newNotif, mPrefix) = stripWorkDoneProgressCancelTokenPrefix notif
|
||||
newMsg = LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel newNotif
|
||||
-- Find IDE with the correct prefix, send to it if it exists. If it doesn't, the message can be thrown away.
|
||||
case mPrefix of
|
||||
Nothing -> void $ sendAllSubIDEs miState newMsg
|
||||
Just prefix -> holdingIDEsAtomic miState $ \ides ->
|
||||
let mIde = find (\ideData -> (ideMessageIdPrefix <$> ideDataMain ideData) == Just prefix) ides
|
||||
in traverse_ (`unsafeSendSubIDESTM` newMsg) $ mIde >>= ideDataMain
|
||||
|
||||
-- Special handing for STextDocumentDefinition to ask multiple IDEs (the W approach)
|
||||
-- When a getDefinition is requested, we cast this request into a tryGetDefinition
|
||||
-- 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
|
||||
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 $ darDependentPackagesVar miState)
|
||||
logDebug miState $ "Shutting down following ides: " <> show idesToShutdown
|
||||
traverse_ (lenientRebootIdeByHome miState) idesToShutdown
|
||||
|
||||
void $ updatePackageData miState
|
||||
-- for .daml, we remove entry from the sourceFileHome cache if the file is deleted (note that renames/moves are sent as delete then create)
|
||||
_ | takeExtension changedPath == ".daml" && changeType == LSP.FcDeleted -> 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 $ subIDEsVar miState
|
||||
traverse_ (handleExit miState) $ Map.mapMaybe ideDataMain ides
|
||||
-- Wait half a second for all the exit messages to be sent
|
||||
threadDelay 500_000
|
||||
exitSuccess
|
||||
|
||||
LSP.FromClientMess meth params ->
|
||||
case getMessageForwardingBehaviour 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 (fromClientMethodTrackerVar miState) _id _method msg' ides combine
|
||||
|
||||
ForwardNotification mess (Single path) -> do
|
||||
logDebug miState $ "single not on method " <> show meth <> " over path " <> path
|
||||
handleOpenFilesNotification miState mess path
|
||||
-- Notifications aren't stored, so failure to send can be ignored
|
||||
sendSubIDEByPath miState path (castFromClientMessage msg)
|
||||
|
||||
ForwardNotification _ AllNotification -> do
|
||||
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
|
||||
_ -> pure ()
|
||||
|
||||
{-
|
||||
TODO: refactor multi-package.yaml discovery logic
|
||||
Expect a multi-package.yaml at the workspace root
|
||||
If we do not get one, we continue as normal (no popups) until the user attempts to open/use files in a different package to the first one
|
||||
When this occurs, this send a popup:
|
||||
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 = multiPackageHome miState
|
||||
|
||||
-- Take locks, throw away current data
|
||||
atomically $ do
|
||||
void $ takeTMVar (multiPackageMappingVar miState)
|
||||
void $ takeTMVar (darDependentPackagesVar miState)
|
||||
|
||||
mPkgConfig <- findMultiPackageConfig $ ProjectPath ideRoot
|
||||
case mPkgConfig of
|
||||
Nothing -> do
|
||||
logDebug miState "No multi-package.yaml found"
|
||||
damlYamlExists <- doesFileExist $ ideRoot </> projectConfigName
|
||||
if damlYamlExists
|
||||
then do
|
||||
logDebug miState "Found daml.yaml"
|
||||
-- Treat a workspace with only daml.yaml as a multi-package project with only one package
|
||||
deriveAndWriteMappings [PackageHome ideRoot] []
|
||||
else do
|
||||
logDebug miState "No daml.yaml found either"
|
||||
-- Without a multi-package or daml.yaml, no mappings can be made. Passing empty lists here will give empty mappings
|
||||
deriveAndWriteMappings [] []
|
||||
Just path -> do
|
||||
logDebug miState "Found multi-package.yaml"
|
||||
(eRes :: Either SomeException [PackageHome]) <- try @SomeException $ withMultiPackageConfig path $ \multiPackage ->
|
||||
deriveAndWriteMappings
|
||||
(PackageHome . toPosixFilePath <$> mpPackagePaths multiPackage)
|
||||
(DarFile . toPosixFilePath <$> mpDars multiPackage)
|
||||
let multiPackagePath = toPosixFilePath $ unwrapProjectPath path </> "multi-package.yaml"
|
||||
case eRes of
|
||||
Right paths -> do
|
||||
-- On success, clear any diagnostics on the multi-package.yaml
|
||||
sendClient miState $ clearDiagnostics multiPackagePath
|
||||
pure paths
|
||||
Left err -> do
|
||||
-- If the computation fails, the mappings may be empty, so ensure the TMVars have values
|
||||
atomically $ do
|
||||
void $ tryPutTMVar (multiPackageMappingVar miState) Map.empty
|
||||
void $ tryPutTMVar (darDependentPackagesVar miState) Map.empty
|
||||
-- Show the failure as a diagnostic on the multi-package.yaml
|
||||
sendClient miState $ fullFileDiagnostic ("Error reading multi-package.yaml:\n" <> displayException err) multiPackagePath
|
||||
pure []
|
||||
where
|
||||
-- Gets the unit id of a dar if it can, caches result in stateT
|
||||
-- Returns Nothing (and stores) if anything goes wrong (dar doesn't exist, dar isn't archive, dar manifest malformed, etc.)
|
||||
getDarUnitId :: DarFile -> StateT (Map.Map DarFile (Maybe UnitId)) IO (Maybe UnitId)
|
||||
getDarUnitId dep = do
|
||||
cachedResult <- gets (Map.lookup dep)
|
||||
case cachedResult of
|
||||
Just res -> pure res
|
||||
Nothing -> do
|
||||
mUnitId <- lift $ fmap eitherToMaybe $ try @SomeException $ do
|
||||
archive <- Zip.toArchive <$> BSL.readFile (unDarFile dep)
|
||||
manifest <- either fail pure $ readDalfManifest archive
|
||||
-- Manifest "packageName" is actually unit id
|
||||
maybe (fail $ "data-dependency " <> unDarFile dep <> " missing a package name") (pure . UnitId) $ packageName manifest
|
||||
modify' $ Map.insert dep mUnitId
|
||||
pure mUnitId
|
||||
|
||||
deriveAndWriteMappings :: [PackageHome] -> [DarFile] -> IO [PackageHome]
|
||||
deriveAndWriteMappings packagePaths darPaths = do
|
||||
packedMappingData <- flip runStateT mempty $ do
|
||||
-- load cache with all multi-package dars, so they'll be present in darUnitIds
|
||||
traverse_ getDarUnitId darPaths
|
||||
fmap (bimap catMaybes catMaybes . unzip) $ forM packagePaths $ \packagePath -> do
|
||||
mUnitIdAndDeps <- lift $ fmap eitherToMaybe $ unitIdAndDepsFromDamlYaml packagePath
|
||||
case mUnitIdAndDeps of
|
||||
Just (unitId, deps) -> do
|
||||
allDepsValid <- isJust . sequence <$> traverse getDarUnitId deps
|
||||
pure (if allDepsValid then Nothing else Just packagePath, Just (packagePath, unitId, deps))
|
||||
_ -> pure (Just packagePath, Nothing)
|
||||
|
||||
let invalidHomes :: [PackageHome]
|
||||
validPackageDatas :: [(PackageHome, UnitId, [DarFile])]
|
||||
darUnitIds :: Map.Map DarFile (Maybe UnitId)
|
||||
((invalidHomes, validPackageDatas), darUnitIds) = packedMappingData
|
||||
packagesOnDisk :: Map.Map UnitId PackageSourceLocation
|
||||
packagesOnDisk =
|
||||
Map.fromList $ (\(packagePath, unitId, _) -> (unitId, PackageOnDisk packagePath)) <$> validPackageDatas
|
||||
darMapping :: Map.Map UnitId PackageSourceLocation
|
||||
darMapping =
|
||||
Map.fromList $ fmap (\(packagePath, unitId) -> (unitId, PackageInDar packagePath)) $ Map.toList $ Map.mapMaybe id darUnitIds
|
||||
multiPackageMapping :: Map.Map UnitId PackageSourceLocation
|
||||
multiPackageMapping = packagesOnDisk <> darMapping
|
||||
darDependentPackages :: Map.Map DarFile (Set.Set PackageHome)
|
||||
darDependentPackages = foldr
|
||||
(\(packagePath, _, deps) -> Map.unionWith (<>) $ Map.fromList $ (,Set.singleton packagePath) <$> deps
|
||||
) Map.empty validPackageDatas
|
||||
|
||||
logDebug miState $ "Setting multi package mapping to:\n" <> show multiPackageMapping
|
||||
logDebug miState $ "Setting dar dependent packages to:\n" <> show darDependentPackages
|
||||
atomically $ do
|
||||
putTMVar (multiPackageMappingVar miState) multiPackageMapping
|
||||
putTMVar (darDependentPackagesVar miState) darDependentPackages
|
||||
|
||||
pure invalidHomes
|
||||
import System.Process.Typed (ExitCode (..), getExitCodeSTM)
|
||||
|
||||
-- Main loop logic
|
||||
|
||||
createDefaultPackage :: SdkVersion.Class.SdkVersioned => IO (PackageHome, IO ())
|
||||
createDefaultPackage = do
|
||||
(toPosixFilePath -> defaultPackagePath, cleanup) <- newTempDir
|
||||
writeFile (defaultPackagePath </> "daml.yaml") $ unlines
|
||||
(toPosixFilePath -> misDefaultPackagePath, cleanup) <- newTempDir
|
||||
writeFile (misDefaultPackagePath </> "daml.yaml") $ unlines
|
||||
[ "sdk-version: " <> SdkVersion.Class.sdkVersion
|
||||
, "name: daml-ide-default-environment"
|
||||
, "version: 1.0.0"
|
||||
@ -879,14 +46,14 @@ createDefaultPackage = do
|
||||
, " - daml-prim"
|
||||
, " - daml-stdlib"
|
||||
]
|
||||
pure (PackageHome defaultPackagePath, cleanup)
|
||||
pure (PackageHome misDefaultPackagePath, cleanup)
|
||||
|
||||
runMultiIde :: SdkVersion.Class.SdkVersioned => Logger.Priority -> [String] -> IO ()
|
||||
runMultiIde loggingThreshold args = do
|
||||
homePath <- toPosixFilePath <$> getCurrentDirectory
|
||||
(defaultPackagePath, cleanupDefaultPackage) <- createDefaultPackage
|
||||
let subIdeArgs = if loggingThreshold <= Logger.Debug then "--debug" : args else args
|
||||
miState <- newMultiIdeState homePath defaultPackagePath loggingThreshold subIdeArgs
|
||||
(misDefaultPackagePath, cleanupDefaultPackage) <- createDefaultPackage
|
||||
let misSubIdeArgs = if loggingThreshold <= Logger.Debug then "--debug" : args else args
|
||||
miState <- newMultiIdeState homePath misDefaultPackagePath loggingThreshold misSubIdeArgs subIdeMessageHandler
|
||||
invalidPackageHomes <- updatePackageData miState
|
||||
|
||||
-- Ensure we don't send messages to the client until it finishes initializing
|
||||
@ -895,7 +62,7 @@ runMultiIde loggingThreshold args = do
|
||||
logInfo miState $ "Running with logging threshold of " <> show loggingThreshold
|
||||
-- Client <- *****
|
||||
toClientThread <- async $ onceUnblocked $ forever $ do
|
||||
msg <- atomically $ readTChan $ toClientChan miState
|
||||
msg <- atomically $ readTChan $ misToClientChan miState
|
||||
logDebug miState $ "Pushing message to client:\n" <> BSLC.unpack msg
|
||||
putChunk stdout msg
|
||||
|
||||
@ -904,16 +71,16 @@ runMultiIde loggingThreshold args = do
|
||||
onChunks stdin $ clientMessageHandler miState unblock
|
||||
|
||||
-- All invalid packages get spun up, so their errors are shown
|
||||
traverse_ (\home -> addNewSubIDEAndSend miState home Nothing) invalidPackageHomes
|
||||
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)
|
||||
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)]
|
||||
-- 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]
|
||||
@ -921,21 +88,21 @@ runMultiIde loggingThreshold args = do
|
||||
errorOutcomes = (home, ide, ) . Right <$> errs
|
||||
pure $ errorOutcomes <> maybeToList mExitOutcome
|
||||
|
||||
-- Function folded over outcomes to update SubIDEs, keep error list and list subIDEs to reboot
|
||||
-- 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) =
|
||||
:: ([(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
|
||||
-- subIde process exits
|
||||
Left exitCode -> do
|
||||
logDebug miState $ "SubIDE at " <> unPackageHome home <> " exited, cleaning up."
|
||||
logDebug miState $ "SubIde at " <> unPackageHome home <> " exited, cleaning up."
|
||||
traverse_ hTryClose [ideInHandle ide, ideOutHandle ide, ideErrHandle ide]
|
||||
traverse_ cancel [ideInhandleAsync ide, ideOutHandleAsync ide, ideErrTextAsync ide]
|
||||
stderrContent <- T.unpack <$> readTVarIO (ideErrText ide)
|
||||
currentTime <- getCurrentTime
|
||||
let ideData = lookupSubIde home subIDEs
|
||||
let ideData = lookupSubIde home subIdes
|
||||
isMainIde = ideDataMain ideData == Just ide
|
||||
isCrash = exitCode /= ExitSuccess
|
||||
ideData' = ideData
|
||||
@ -951,15 +118,15 @@ runMultiIde loggingThreshold args = do
|
||||
when (isCrash && isMainIde) $
|
||||
logWarning miState $ "Proccess failed, stderr content:\n" <> stderrContent
|
||||
|
||||
pure (errs, Map.insert home ideData' subIDEs, toRestart')
|
||||
pure (errs, Map.insert home ideData' subIdes, toRestart')
|
||||
-- handler thread errors
|
||||
Right exception -> pure ((home, exception) : errs, subIDEs, toRestart)
|
||||
Right exception -> pure ((home, exception) : errs, subIdes, toRestart)
|
||||
|
||||
forever $ do
|
||||
(outcomes, clientThreadExceptions) <- atomically $ do
|
||||
subIDEs <- readTMVar $ subIDEsVar miState
|
||||
subIdes <- readTMVar $ misSubIdesVar miState
|
||||
|
||||
outcomes <- fmap concat $ forM (Map.toList subIDEs) $ \(home, subIdeData) -> do
|
||||
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
|
||||
@ -981,10 +148,10 @@ runMultiIde loggingThreshold args = do
|
||||
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
|
||||
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)
|
||||
error $ "SubIde handlers failed with following errors:\n" <> unlines ((\(home, err) -> unPackageHome home <> " => " <> show err) <$> errs)
|
||||
|
||||
@ -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
|
||||
@ -32,7 +32,7 @@ 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
|
||||
-- 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
|
||||
@ -117,7 +117,7 @@ extractPackageMetadataFromDalfPath path =
|
||||
_ -> ("", "", "")
|
||||
|
||||
unpackedDarsLocation :: MultiIdeState -> FilePath
|
||||
unpackedDarsLocation miState = multiPackageHome miState </> ".daml" </> "unpacked-dars"
|
||||
unpackedDarsLocation miState = misMultiPackageHome miState </> ".daml" </> "unpacked-dars"
|
||||
|
||||
unpackedDarPath :: MultiIdeState -> String -> String -> PackageHome
|
||||
unpackedDarPath miState pkgName pkgVersion = PackageHome $ unpackedDarsLocation miState </> pkgName <> "-" <> pkgVersion
|
||||
|
||||
@ -3,14 +3,10 @@
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
-- We generate missing instances for SignatureHelpParams
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
@ -190,5 +186,5 @@ filePathFromURI miState uri =
|
||||
vr <- uriToVirtualResource parsedUri
|
||||
pure $ LSP.fromNormalizedFilePath $ vrScenarioFile vr
|
||||
"untitled:" ->
|
||||
pure $ unPackageHome $ defaultPackagePath miState
|
||||
pure $ unPackageHome $ misDefaultPackagePath miState
|
||||
_ -> Nothing
|
||||
|
||||
313
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Handlers.hs
Normal file
313
sdk/compiler/damlc/lib/DA/Cli/Damlc/Command/MultiIde/Handlers.hs
Normal file
@ -0,0 +1,313 @@
|
||||
-- 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.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"
|
||||
-- Dangerous call here is acceptable as this only happens while the ide is booting, before unblocking
|
||||
unsafeSendSubIde ide $ LSP.FromClientMess LSP.SInitialized $ LSP.NotificationMessage "2.0" LSP.SInitialized (Just LSP.InitializedParams)
|
||||
unblock
|
||||
LSP.FromServerRsp LSP.SShutdown (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
|
||||
let LSP.RequestMessage {_id, _method} = registerFileWatchersMessage
|
||||
putReqMethodSingleFromServerCoordinator (misFromServerMethodTrackerVar miState) _id _method
|
||||
|
||||
sendClient miState $ LSP.FromServerMess _method registerFileWatchersMessage
|
||||
|
||||
LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel notif -> do
|
||||
let (newNotif, mPrefix) = stripWorkDoneProgressCancelTokenPrefix notif
|
||||
newMsg = LSP.FromClientMess LSP.SWindowWorkDoneProgressCancel newNotif
|
||||
-- Find IDE with the correct prefix, send to it if it exists. If it doesn't, the message can be thrown away.
|
||||
case mPrefix of
|
||||
Nothing -> void $ sendAllSubIdes miState newMsg
|
||||
Just prefix -> holdingIDEsAtomic miState $ \ides ->
|
||||
let mIde = find (\ideData -> (ideMessageIdPrefix <$> ideDataMain ideData) == Just prefix) ides
|
||||
in traverse_ (`unsafeSendSubIdeSTM` newMsg) $ mIde >>= ideDataMain
|
||||
|
||||
-- Special handing for STextDocumentDefinition to ask multiple IDEs (the W approach)
|
||||
-- When a getDefinition is requested, we cast this request into a tryGetDefinition
|
||||
-- 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
|
||||
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
|
||||
_ -> pure ()
|
||||
@ -0,0 +1,94 @@
|
||||
-- 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,
|
||||
) 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.Extended as TE
|
||||
import GHC.Conc (unsafeIOToSTM)
|
||||
|
||||
onOpenFiles :: MultiIdeState -> PackageHome -> (Set.Set DamlFile -> Set.Set DamlFile) -> STM ()
|
||||
onOpenFiles miState home f = modifyTMVarM (misSubIdesVar miState) $ \subIdes -> do
|
||||
let ideData = lookupSubIde home subIdes
|
||||
ideData' = ideData {ideDataOpenFiles = f $ ideDataOpenFiles ideData}
|
||||
when (ideDataDisabled ideData') $ traverse_ (sendClientSTM miState) $ disableIdeDiagnosticMessages ideData'
|
||||
pure $ Map.insert home ideData' subIdes
|
||||
|
||||
addOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM ()
|
||||
addOpenFile miState home file = do
|
||||
unsafeIOToSTM $ logInfo miState $ "Added open file " <> unDamlFile file <> " to " <> unPackageHome home
|
||||
onOpenFiles miState home $ Set.insert file
|
||||
|
||||
removeOpenFile :: MultiIdeState -> PackageHome -> DamlFile -> STM ()
|
||||
removeOpenFile miState home file = do
|
||||
unsafeIOToSTM $ logInfo miState $ "Removed open file " <> unDamlFile file <> " from " <> unPackageHome home
|
||||
onOpenFiles miState home $ Set.delete file
|
||||
|
||||
-- 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
|
||||
when (ideDataDisabled newHomeIdeData') $ traverse_ (sendClientSTM miState) $ disableIdeDiagnosticMessages 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'
|
||||
@ -0,0 +1,138 @@
|
||||
-- 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 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 ("Error reading multi-package.yaml:\n" <> displayException err) multiPackagePath
|
||||
pure []
|
||||
where
|
||||
-- Gets the unit id of a dar if it can, caches result in stateT
|
||||
-- Returns Nothing (and stores) if anything goes wrong (dar doesn't exist, dar isn't archive, dar manifest malformed, etc.)
|
||||
getDarUnitId :: DarFile -> StateT (Map.Map DarFile (Maybe UnitId)) IO (Maybe UnitId)
|
||||
getDarUnitId dep = do
|
||||
cachedResult <- gets (Map.lookup dep)
|
||||
case cachedResult of
|
||||
Just res -> pure res
|
||||
Nothing -> do
|
||||
mUnitId <- lift $ fmap eitherToMaybe $ try @SomeException $ do
|
||||
archive <- Zip.toArchive <$> BSL.readFile (unDarFile dep)
|
||||
manifest <- either fail pure $ readDalfManifest archive
|
||||
-- Manifest "packageName" is actually unit id
|
||||
maybe (fail $ "data-dependency " <> unDarFile dep <> " missing a package name") (pure . UnitId) $ packageName manifest
|
||||
modify' $ Map.insert dep mUnitId
|
||||
pure mUnitId
|
||||
|
||||
deriveAndWriteMappings :: [PackageHome] -> [DarFile] -> IO [PackageHome]
|
||||
deriveAndWriteMappings packagePaths darPaths = do
|
||||
packedMappingData <- flip runStateT mempty $ do
|
||||
-- load cache with all multi-package dars, so they'll be present in darUnitIds
|
||||
traverse_ getDarUnitId darPaths
|
||||
fmap (bimap catMaybes catMaybes . unzip) $ forM packagePaths $ \packagePath -> do
|
||||
mUnitIdAndDeps <- lift $ fmap eitherToMaybe $ unitIdAndDepsFromDamlYaml packagePath
|
||||
case mUnitIdAndDeps of
|
||||
Just (unitId, deps) -> do
|
||||
allDepsValid <- isJust . sequence <$> traverse getDarUnitId deps
|
||||
pure (if allDepsValid then Nothing else Just packagePath, Just (packagePath, unitId, deps))
|
||||
_ -> pure (Just packagePath, Nothing)
|
||||
|
||||
let invalidHomes :: [PackageHome]
|
||||
validPackageDatas :: [(PackageHome, UnitId, [DarFile])]
|
||||
darUnitIds :: Map.Map DarFile (Maybe UnitId)
|
||||
((invalidHomes, validPackageDatas), darUnitIds) = packedMappingData
|
||||
packagesOnDisk :: Map.Map UnitId PackageSourceLocation
|
||||
packagesOnDisk =
|
||||
Map.fromList $ (\(packagePath, unitId, _) -> (unitId, PackageOnDisk packagePath)) <$> validPackageDatas
|
||||
darMapping :: Map.Map UnitId PackageSourceLocation
|
||||
darMapping =
|
||||
Map.fromList $ fmap (\(packagePath, unitId) -> (unitId, PackageInDar packagePath)) $ Map.toList $ Map.mapMaybe id darUnitIds
|
||||
multiPackageMapping :: Map.Map UnitId PackageSourceLocation
|
||||
multiPackageMapping = packagesOnDisk <> darMapping
|
||||
darDependentPackages :: Map.Map DarFile (Set.Set PackageHome)
|
||||
darDependentPackages = foldr
|
||||
(\(packagePath, _, deps) -> Map.unionWith (<>) $ Map.fromList $ (,Set.singleton packagePath) <$> deps
|
||||
) Map.empty validPackageDatas
|
||||
|
||||
logDebug miState $ "Setting multi package mapping to:\n" <> show multiPackageMapping
|
||||
logDebug miState $ "Setting dar dependent packages to:\n" <> show darDependentPackages
|
||||
atomically $ do
|
||||
putTMVar (misMultiPackageMappingVar miState) multiPackageMapping
|
||||
putTMVar (misDarDependentPackagesVar miState) darDependentPackages
|
||||
|
||||
pure invalidHomes
|
||||
@ -1,12 +1,9 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Parsing (
|
||||
@ -91,8 +88,8 @@ putReqMethodSingleFromServerCoordinator tracker id method = putReqMethod tracker
|
||||
putFromServerMessage :: MultiIdeState -> PackageHome -> LSP.FromServerMessage -> IO ()
|
||||
putFromServerMessage miState home (LSP.FromServerMess method mess) =
|
||||
case (LSP.splitServerMethod method, mess) of
|
||||
(LSP.IsServerReq, _) -> putReqMethodSingleFromServer (fromServerMethodTrackerVar miState) home (mess ^. LSP.id) method
|
||||
(LSP.IsServerEither, LSP.ReqMess mess) -> putReqMethodSingleFromServer (fromServerMethodTrackerVar miState) home (mess ^. LSP.id) method
|
||||
(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 ()
|
||||
|
||||
@ -105,8 +102,8 @@ putReqMethodSingleFromClient tracker id method message home = putReqMethod track
|
||||
putSingleFromClientMessage :: MultiIdeState -> PackageHome -> LSP.FromClientMessage -> IO ()
|
||||
putSingleFromClientMessage miState home msg@(LSP.FromClientMess method mess) =
|
||||
case (LSP.splitClientMethod method, mess) of
|
||||
(LSP.IsClientReq, _) -> putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) (mess ^. LSP.id) method msg home
|
||||
(LSP.IsClientEither, LSP.ReqMess mess) -> putReqMethodSingleFromClient (fromClientMethodTrackerVar miState) (mess ^. LSP.id) method msg home
|
||||
(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 ()
|
||||
|
||||
@ -216,7 +213,7 @@ adjustClientTrackers
|
||||
-> (Maybe (TrackedMethod m), Maybe a)
|
||||
)
|
||||
-> IO [a]
|
||||
adjustClientTrackers miState home adjuster = atomically $ stateTVar (fromClientMethodTrackerVar miState) $ \tracker ->
|
||||
adjustClientTrackers miState home adjuster = atomically $ stateTVar (misFromClientMethodTrackerVar miState) $ \tracker ->
|
||||
let doAdjust
|
||||
:: forall (m :: LSP.Method 'LSP.FromClient 'LSP.Request)
|
||||
. [a]
|
||||
@ -231,7 +228,7 @@ adjustClientTrackers miState home adjuster = atomically $ stateTVar (fromClientM
|
||||
(TrackedSingleMethodFromClient _ _ home', LSP.SomeLspId lspId) | home == home' -> doAdjust accum (unsafeCoerce lspId) tracker
|
||||
(TrackedAllMethod {tamRemainingResponsePackageHomes}, LSP.SomeLspId lspId) | home `elem` tamRemainingResponsePackageHomes -> doAdjust accum (unsafeCoerce lspId) tracker
|
||||
_ -> (accum, Just someTracker)
|
||||
-- We know that the fromClientMethodTrackerVar only contains Trackers for FromClient, but this information is lost in the `Some` inside the IxMap
|
||||
-- We 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)
|
||||
@ -239,14 +236,14 @@ adjustClientTrackers miState home adjuster = atomically $ stateTVar (fromClientM
|
||||
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 :: 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 :: 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)
|
||||
@ -257,7 +254,7 @@ getUnrespondedRequestsToResend miState ideData home = adjustClientTrackers miSta
|
||||
-- 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 :: 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)
|
||||
|
||||
@ -3,15 +3,9 @@
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# 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.
|
||||
-- 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,
|
||||
@ -30,38 +24,38 @@ 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.
|
||||
-- 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.
|
||||
-- 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 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.
|
||||
-- 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
|
||||
= SubIdePrefix T.Text
|
||||
| ClientPrefix
|
||||
|
||||
progressTokenPrefixToText :: ProgressTokenPrefix -> T.Text
|
||||
progressTokenPrefixToText (SubIDEPrefix t) = t
|
||||
progressTokenPrefixToText (SubIdePrefix t) = t
|
||||
progressTokenPrefixToText ClientPrefix = "client"
|
||||
|
||||
progressTokenPrefixFromMaybe :: Maybe T.Text -> ProgressTokenPrefix
|
||||
progressTokenPrefixFromMaybe = maybe ClientPrefix SubIDEPrefix
|
||||
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
|
||||
@ -74,7 +68,7 @@ addProgressTokenPrefix prefix (LSP.ProgressTextToken t) = LSP.ProgressTextToken
|
||||
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
|
||||
-- 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
|
||||
@ -82,19 +76,19 @@ 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.
|
||||
-- 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)
|
||||
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
|
||||
-- ProgressToken was created by this subIde, add its usual prefix
|
||||
(unprefixedToken, Nothing) ->
|
||||
let prefixedToken = addProgressTokenPrefix (SubIDEPrefix prefix) unprefixedToken
|
||||
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."
|
||||
(_, 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.
|
||||
@ -168,23 +162,23 @@ getProgressLenses = \case
|
||||
=> 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
|
||||
-- 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
|
||||
-- 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)
|
||||
-- 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.
|
||||
-- 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"
|
||||
@ -206,7 +200,7 @@ stripLspPrefix (LSP.IdString (T.uncons -> Just ('t', rest))) = LSP.IdString $ T.
|
||||
stripLspPrefix t = t
|
||||
|
||||
-- Prefixes applied to builtin and custom requests. Notifications do not have ids, responses do not need this logic.
|
||||
addLspPrefixToServerMessage :: SubIDEInstance -> LSP.FromServerMessage -> LSP.FromServerMessage
|
||||
addLspPrefixToServerMessage :: SubIdeInstance -> LSP.FromServerMessage -> LSP.FromServerMessage
|
||||
addLspPrefixToServerMessage _ res@(LSP.FromServerRsp _ _) = res
|
||||
addLspPrefixToServerMessage ide res@(LSP.FromServerMess method params) =
|
||||
case LSP.splitServerMethod method of
|
||||
|
||||
@ -0,0 +1,86 @@
|
||||
-- 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 qualified Data.Set as Set
|
||||
import GHC.Conc (unsafeIOToSTM)
|
||||
import qualified Language.LSP.Types as LSP
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath.Posix (takeDirectory, (</>))
|
||||
|
||||
disableIdeDiagnosticMessages :: SubIdeData -> [LSP.FromServerMessage]
|
||||
disableIdeDiagnosticMessages ideData =
|
||||
fullFileDiagnostic
|
||||
( "Daml IDE environment failed to start with the following error:\n"
|
||||
<> fromMaybe "No information" (ideDataLastError ideData)
|
||||
)
|
||||
<$> ((unPackageHome (ideDataHome ideData) </> "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData))
|
||||
|
||||
clearIdeDiagnosticMessages :: SubIdeData -> [LSP.FromServerMessage]
|
||||
clearIdeDiagnosticMessages ideData =
|
||||
clearDiagnostics <$> ((unPackageHome (ideDataHome ideData) </> "daml.yaml") : fmap unDamlFile (Set.toList $ ideDataOpenFiles ideData))
|
||||
|
||||
-- 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)
|
||||
@ -0,0 +1,306 @@
|
||||
-- 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.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.STM
|
||||
import DA.Cli.Damlc.Command.MultiIde.ClientCommunication
|
||||
import DA.Cli.Damlc.Command.MultiIde.Util
|
||||
import DA.Cli.Damlc.Command.MultiIde.Parsing
|
||||
import DA.Cli.Damlc.Command.MultiIde.Types
|
||||
import DA.Cli.Damlc.Command.MultiIde.SubIdeCommunication
|
||||
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"
|
||||
|
||||
let ideData = lookupSubIde home ides
|
||||
case ideDataMain ideData of
|
||||
Just ide -> do
|
||||
logDebug miState "SubIde already exists"
|
||||
forM_ mMsg $ unsafeSendSubIde ide
|
||||
pure ides
|
||||
Nothing | ideShouldDisable ideData || ideDataDisabled ideData -> do
|
||||
when (ideShouldDisable ideData) $ logDebug miState $ "SubIde failed twice within " <> show ideShouldDisableTimeout <> ", disabling SubIde"
|
||||
|
||||
responses <- getUnrespondedRequestsFallbackResponses miState ideData home
|
||||
logDebug miState $ "Found " <> show (length responses) <> " unresponded messages, sending empty replies."
|
||||
|
||||
-- Doesn't include mMsg, as if it was request, it'll already be in the tracker, so a reply for it will be in `responses`
|
||||
-- As such, we cannot send this on every failed message,
|
||||
let ideData' = ideData {ideDataDisabled = True, ideDataFailTimes = []}
|
||||
-- Only add diagnostic messages for first fail to start.
|
||||
-- Diagnostic messages trigger the client to send a codeAction request, which would create an infinite loop if we sent
|
||||
-- diagnostics with its reply
|
||||
messages = responses <> if ideShouldDisable ideData then disableIdeDiagnosticMessages ideData else []
|
||||
|
||||
atomically $ traverse_ (sendClientSTM miState) messages
|
||||
pure $ Map.insert home ideData' ides
|
||||
Nothing -> do
|
||||
logInfo miState $ "Creating new SubIde for " <> unPackageHome home
|
||||
traverse_ (sendClient miState) $ clearIdeDiagnosticMessages ideData
|
||||
|
||||
unitId <- either (\cErr -> error $ "Failed to get unit ID from daml.yaml: " <> show cErr) fst <$> unitIdAndDepsFromDamlYaml 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 = unitId
|
||||
}
|
||||
ideData' = ideData {ideDataMain = Just ide}
|
||||
!initParams = fromMaybe (error "Attempted to create a SubIde before initialization!") mInitParams
|
||||
initMsg = initializeRequest initParams ide
|
||||
|
||||
-- Must happen before the initialize message is added, else it'll delete that
|
||||
unrespondedRequests <- getUnrespondedRequestsToResend miState ideData home
|
||||
|
||||
logDebug miState "Sending init message to SubIde"
|
||||
putSingleFromClientMessage miState home initMsg
|
||||
unsafeSendSubIde ide initMsg
|
||||
|
||||
-- Dangerous calls are okay here because we're already holding the 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) || ideDataDisabled ideData
|
||||
ides' <- unsafeShutdownIdeByHome miState ides home
|
||||
if shouldBoot
|
||||
then unsafeAddNewSubIdeAndSend miState ides' home Nothing
|
||||
else pure ides'
|
||||
|
||||
-- Checks if a shutdown message LspId originated from the multi-ide coordinator
|
||||
isCoordinatorShutdownLspId :: LSP.LspId 'LSP.Shutdown -> Bool
|
||||
isCoordinatorShutdownLspId (LSP.IdString str) = "-shutdown" `T.isSuffixOf` str
|
||||
isCoordinatorShutdownLspId _ = False
|
||||
|
||||
-- Sends a shutdown message and moves SubIdeInstance to `ideDataClosing`, disallowing any further client messages to be sent to the subIde
|
||||
-- given queue nature of TChan, all other pending messages will be sent first before handling shutdown
|
||||
shutdownIdeByHome :: MultiIdeState -> PackageHome -> IO ()
|
||||
shutdownIdeByHome miState home = withIDEs_ miState $ \ides -> unsafeShutdownIdeByHome miState ides home
|
||||
|
||||
-- Unsafe as does not acquire SubIdesVar, instead simply transforms it
|
||||
unsafeShutdownIdeByHome :: MultiIdeState -> SubIdes -> PackageHome -> IO SubIdes
|
||||
unsafeShutdownIdeByHome miState ides home = do
|
||||
let ideData = lookupSubIde home ides
|
||||
case ideDataMain ideData of
|
||||
Just ide -> do
|
||||
let shutdownId = LSP.IdString $ ideMessageIdPrefix ide <> "-shutdown"
|
||||
shutdownMsg :: LSP.FromClientMessage
|
||||
shutdownMsg = LSP.FromClientMess LSP.SShutdown LSP.RequestMessage
|
||||
{ _id = shutdownId
|
||||
, _method = LSP.SShutdown
|
||||
, _params = LSP.Empty
|
||||
, _jsonrpc = "2.0"
|
||||
}
|
||||
|
||||
logDebug miState $ "Sending shutdown message to " <> unPackageHome (ideDataHome ideData)
|
||||
|
||||
putSingleFromClientMessage miState home shutdownMsg
|
||||
unsafeSendSubIde ide shutdownMsg
|
||||
pure $ Map.adjust (\ideData' -> ideData'
|
||||
{ ideDataMain = Nothing
|
||||
, ideDataClosing = Set.insert ide $ ideDataClosing ideData
|
||||
, ideDataFailTimes = []
|
||||
, ideDataDisabled = False
|
||||
}) home ides
|
||||
Nothing ->
|
||||
pure $ Map.adjust (\ideData -> ideData {ideDataFailTimes = [], ideDataDisabled = False}) home ides
|
||||
|
||||
-- To be called once we receive the Shutdown response
|
||||
-- Safe to assume that the sending channel is empty, so we can end the thread and send the final notification directly on the handle
|
||||
handleExit :: MultiIdeState -> 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
|
||||
@ -1,12 +1,9 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Types (
|
||||
@ -21,6 +18,7 @@ import Control.Concurrent.MVar
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.STM
|
||||
import DA.Daml.Project.Types (ProjectPath (..))
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Function (on)
|
||||
import qualified Data.IxMap as IM
|
||||
@ -49,8 +47,8 @@ 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
|
||||
-> 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)
|
||||
@ -62,7 +60,7 @@ data TrackedMethod (m :: LSP.Method from 'LSP.Request) where
|
||||
-- ^ The method of the initial request
|
||||
, tamLspId :: LSP.LspId m
|
||||
, tamClientMessage :: LSP.FromClientMessage
|
||||
-- ^ Store the whole message for re-transmission on subIDE restart
|
||||
-- ^ Store the whole message for re-transmission on subIde restart
|
||||
, tamCombiner :: ResponseCombiner m
|
||||
-- ^ How to combine the results from each IDE
|
||||
, tamRemainingResponsePackageHomes :: [PackageHome]
|
||||
@ -88,97 +86,97 @@ 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
|
||||
data SubIdeInstance = SubIdeInstance
|
||||
{ ideInhandleAsync :: Async ()
|
||||
, ideInHandle :: Handle
|
||||
, ideInHandleChannel :: TChan BSL.ByteString
|
||||
, ideOutHandle :: Handle
|
||||
, ideOutHandleAsync :: Async ()
|
||||
-- ^ For sending messages to that SubIDE
|
||||
-- ^ 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
|
||||
-- ^ 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.
|
||||
-- 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
|
||||
-- ^ Unit ID of the package this SubIde handles
|
||||
-- Of the form "daml-script-0.0.1"
|
||||
}
|
||||
|
||||
instance Eq SubIDEInstance where
|
||||
instance Eq SubIdeInstance where
|
||||
-- ideMessageIdPrefix is derived from process id, so this equality is of the process.
|
||||
(==) = (==) `on` ideMessageIdPrefix
|
||||
|
||||
instance Ord SubIDEInstance where
|
||||
instance Ord SubIdeInstance where
|
||||
-- ideMessageIdPrefix is derived from process id, so this ordering is of the process.
|
||||
compare = compare `on` ideMessageIdPrefix
|
||||
|
||||
-- We store an optional main ide, the currently closing ides (kept only so they can reply to their shutdowns), and open files
|
||||
-- open files must outlive the main subide so we can re-send the TextDocumentDidOpen messages on new ide startup
|
||||
data SubIDEData = SubIDEData
|
||||
data SubIdeData = SubIdeData
|
||||
{ ideDataHome :: PackageHome
|
||||
, ideDataMain :: Maybe SubIDEInstance
|
||||
, ideDataClosing :: Set.Set SubIDEInstance
|
||||
, ideDataMain :: Maybe SubIdeInstance
|
||||
, ideDataClosing :: Set.Set SubIdeInstance
|
||||
, ideDataOpenFiles :: Set.Set DamlFile
|
||||
, ideDataFailTimes :: [UTCTime]
|
||||
, ideDataDisabled :: Bool
|
||||
, ideDataLastError :: Maybe String
|
||||
}
|
||||
|
||||
defaultSubIDEData :: PackageHome -> SubIDEData
|
||||
defaultSubIDEData home = SubIDEData home Nothing Set.empty Set.empty [] False Nothing
|
||||
defaultSubIdeData :: PackageHome -> SubIdeData
|
||||
defaultSubIdeData home = SubIdeData home Nothing Set.empty Set.empty [] False Nothing
|
||||
|
||||
lookupSubIde :: PackageHome -> SubIDEs -> SubIDEData
|
||||
lookupSubIde home ides = fromMaybe (defaultSubIDEData home) $ Map.lookup home ides
|
||||
lookupSubIde :: PackageHome -> SubIdes -> SubIdeData
|
||||
lookupSubIde home ides = fromMaybe (defaultSubIdeData home) $ Map.lookup home ides
|
||||
|
||||
ideShouldDisableTimeout :: NominalDiffTime
|
||||
ideShouldDisableTimeout = 5
|
||||
|
||||
ideShouldDisable :: SubIDEData -> Bool
|
||||
ideShouldDisable :: SubIdeData -> Bool
|
||||
ideShouldDisable (ideDataFailTimes -> (t1:t2:_)) = t1 `diffUTCTime` t2 < ideShouldDisableTimeout
|
||||
ideShouldDisable _ = False
|
||||
|
||||
-- SubIDEs placed in a TMVar. The emptyness representents a modification lock.
|
||||
-- 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
|
||||
-- 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
|
||||
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
|
||||
-- Helper functions for holding the subIdes var
|
||||
withIDEsAtomic :: MultiIdeState -> (SubIdes -> STM (SubIdes, a)) -> IO a
|
||||
withIDEsAtomic miState f = atomically $ do
|
||||
ides <- takeTMVar $ subIDEsVar miState
|
||||
ides <- takeTMVar $ misSubIdesVar miState
|
||||
(ides', res) <- f ides
|
||||
putTMVar (subIDEsVar miState) ides'
|
||||
putTMVar (misSubIdesVar miState) ides'
|
||||
pure res
|
||||
|
||||
holdingIDEsAtomic :: MultiIdeState -> (SubIDEs -> STM a) -> IO a
|
||||
holdingIDEsAtomic :: MultiIdeState -> (SubIdes -> STM a) -> IO a
|
||||
holdingIDEsAtomic miState f = withIDEsAtomic miState $ \ides -> (ides,) <$> f ides
|
||||
|
||||
withIDEsAtomic_ :: MultiIdeState -> (SubIDEs -> STM SubIDEs) -> IO ()
|
||||
withIDEsAtomic_ :: MultiIdeState -> (SubIdes -> STM SubIdes) -> IO ()
|
||||
withIDEsAtomic_ miState f = void $ withIDEsAtomic miState $ fmap (, ()) . f
|
||||
|
||||
withIDEs :: MultiIdeState -> (SubIDEs -> IO (SubIDEs, a)) -> IO a
|
||||
withIDEs :: MultiIdeState -> (SubIdes -> IO (SubIdes, a)) -> IO a
|
||||
withIDEs miState f = do
|
||||
ides <- atomically $ takeTMVar $ subIDEsVar miState
|
||||
ides <- atomically $ takeTMVar $ misSubIdesVar miState
|
||||
(ides', res) <- f ides
|
||||
atomically $ putTMVar (subIDEsVar miState) ides'
|
||||
atomically $ putTMVar (misSubIdesVar miState) ides'
|
||||
pure res
|
||||
|
||||
holdingIDEs :: MultiIdeState -> (SubIDEs -> IO a) -> IO a
|
||||
holdingIDEs :: MultiIdeState -> (SubIdes -> IO a) -> IO a
|
||||
holdingIDEs miState f = withIDEs miState $ \ides -> (ides,) <$> f ides
|
||||
|
||||
withIDEs_ :: MultiIdeState -> (SubIDEs -> IO SubIDEs) -> IO ()
|
||||
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.
|
||||
-- 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
|
||||
|
||||
@ -197,47 +195,53 @@ type DarDependentPackagesVar = TMVar DarDependentPackages
|
||||
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 ()
|
||||
|
||||
data MultiIdeState = MultiIdeState
|
||||
{ fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient
|
||||
{ misFromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient
|
||||
-- ^ The client will track its own IDs to ensure they're unique, so no worries about collisions
|
||||
, fromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer
|
||||
-- ^ We will prefix LspIds before they get here based on their SubIDE messageIdPrefix, to avoid collisions
|
||||
, subIDEsVar :: SubIDEsVar
|
||||
, initParamsVar :: InitParamsVar
|
||||
, toClientChan :: TChan BSL.ByteString
|
||||
, multiPackageMappingVar :: MultiPackageYamlMappingVar
|
||||
, darDependentPackagesVar :: DarDependentPackagesVar
|
||||
, logger :: Logger.Handle IO
|
||||
, multiPackageHome :: FilePath
|
||||
, defaultPackagePath :: PackageHome
|
||||
, sourceFileHomesVar :: SourceFileHomesVar
|
||||
, subIdeArgs :: [String]
|
||||
, 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
|
||||
}
|
||||
|
||||
logError :: MultiIdeState -> String -> IO ()
|
||||
logError miState msg = Logger.logError (logger miState) (T.pack msg)
|
||||
logError miState msg = Logger.logError (misLogger miState) (T.pack msg)
|
||||
|
||||
logWarning :: MultiIdeState -> String -> IO ()
|
||||
logWarning miState msg = Logger.logWarning (logger miState) (T.pack msg)
|
||||
logWarning miState msg = Logger.logWarning (misLogger miState) (T.pack msg)
|
||||
|
||||
logInfo :: MultiIdeState -> String -> IO ()
|
||||
logInfo miState msg = Logger.logInfo (logger miState) (T.pack msg)
|
||||
logInfo miState msg = Logger.logInfo (misLogger miState) (T.pack msg)
|
||||
|
||||
logDebug :: MultiIdeState -> String -> IO ()
|
||||
logDebug miState msg = Logger.logDebug (logger miState) (T.pack msg)
|
||||
logDebug miState msg = Logger.logDebug (misLogger miState) (T.pack msg)
|
||||
|
||||
newMultiIdeState :: FilePath -> PackageHome -> Logger.Priority -> [String] -> IO MultiIdeState
|
||||
newMultiIdeState multiPackageHome defaultPackagePath logThreshold subIdeArgs = do
|
||||
(fromClientMethodTrackerVar :: MethodTrackerVar 'LSP.FromClient) <- newTVarIO IM.emptyIxMap
|
||||
(fromServerMethodTrackerVar :: MethodTrackerVar 'LSP.FromServer) <- newTVarIO IM.emptyIxMap
|
||||
subIDEsVar <- newTMVarIO @SubIDEs mempty
|
||||
initParamsVar <- newEmptyMVar @InitParams
|
||||
toClientChan <- atomically newTChan
|
||||
multiPackageMappingVar <- newTMVarIO @MultiPackageYamlMapping mempty
|
||||
darDependentPackagesVar <- newTMVarIO @DarDependentPackages mempty
|
||||
sourceFileHomesVar <- newTMVarIO @SourceFileHomes mempty
|
||||
logger <- Logger.newStderrLogger logThreshold "Multi-IDE"
|
||||
pure MultiIdeState {..}
|
||||
newMultiIdeState :: FilePath -> PackageHome -> Logger.Priority -> [String] -> (MultiIdeState -> SubIdeMessageHandler) -> IO MultiIdeState
|
||||
newMultiIdeState misMultiPackageHome misDefaultPackagePath logThreshold misSubIdeArgs subIdeMessageHandler = 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"
|
||||
let miState = MultiIdeState {misSubIdeMessageHandler = subIdeMessageHandler miState, ..}
|
||||
pure miState
|
||||
|
||||
-- Forwarding
|
||||
|
||||
|
||||
@ -1,12 +1,8 @@
|
||||
-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DisambiguateRecordFields #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
module DA.Cli.Damlc.Command.MultiIde.Util (
|
||||
@ -154,7 +150,7 @@ initializeResult = LSP.InitializeResult
|
||||
true = Just (LSP.InL True)
|
||||
false = Just (LSP.InL False)
|
||||
|
||||
initializeRequest :: InitParams -> SubIDEInstance -> LSP.FromClientMessage
|
||||
initializeRequest :: InitParams -> SubIdeInstance -> LSP.FromClientMessage
|
||||
initializeRequest initParams ide = LSP.FromClientMess LSP.SInitialize LSP.RequestMessage
|
||||
{ _id = LSP.IdString $ ideMessageIdPrefix ide <> "-init"
|
||||
, _method = LSP.SInitialize
|
||||
|
||||
Loading…
Reference in New Issue
Block a user