@@ -0,0 +1,208 @@
1+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+{-# LANGUAGE DuplicateRecordFields #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE RankNTypes #-}
7+module Development.IDE.LSP.Server
8+ ( runServer
9+ , Handlers(..)
10+ ) where
11+
12+
13+import Control.Monad
14+import Control.Concurrent
15+import Control.Concurrent.Async
16+import Control.Concurrent.Extra
17+import Control.Concurrent.STM
18+
19+import Data.Default
20+
21+import Development.IDE.LSP.Protocol
22+import qualified Development.IDE.Logger as Logger
23+
24+import qualified Data.Aeson as Aeson
25+import qualified Data.Aeson.Text as Aeson
26+import qualified Data.Text.Lazy as TL
27+import qualified Data.Text as T
28+
29+import System.IO
30+import GHC.IO.Handle (hDuplicate, hDuplicateTo)
31+
32+import qualified Language.Haskell.LSP.Control as LSP
33+import qualified Language.Haskell.LSP.Core as LSP
34+import qualified Language.Haskell.LSP.Messages as LSP
35+import qualified Language.Haskell.LSP.Types as LSP
36+
37+------------------------------------------------------------------------
38+-- Server execution
39+------------------------------------------------------------------------
40+
41+data Handlers = Handlers
42+ { requestHandler
43+ :: (forall resp. resp -> ResponseMessage resp)
44+ -> (ErrorCode -> ResponseMessage ())
45+ -> ServerRequest
46+ -> IO LSP.FromServerMessage
47+ , notificationHandler
48+ :: ServerNotification -> IO ()
49+ }
50+
51+runServer
52+ :: Logger.Handle
53+ -> (LSP.LspFuncs () -> IO Handlers)
54+ -- ^ Notification handler for language server notifications
55+ -> IO ()
56+runServer loggerH getHandlers = do
57+ -- DEL-6257: Move stdout to another file descriptor and duplicate stderr
58+ -- to stdout. This guards against stray prints from corrupting the JSON-RPC
59+ -- message stream.
60+ newStdout <- hDuplicate stdout
61+ stderr `hDuplicateTo` stdout
62+
63+ -- Print out a single space to assert that the above redirection works.
64+ -- This is interleaved with the logger, hence we just print a space here in
65+ -- order not to mess up the output too much. Verified that this breaks
66+ -- the language server tests without the redirection.
67+ putStr " " >> hFlush stdout
68+ clientMsgChan <- newTChanIO
69+ -- These barriers are signaled when the threads reading from these chans exit.
70+ -- This should not happen but if it does, we will make sure that the whole server
71+ -- dies and can be restarted instead of losing threads silently.
72+ clientMsgBarrier <- newBarrier
73+ void $ waitAnyCancel =<< traverse async
74+ [ void $ LSP.runWithHandles
75+ stdin
76+ newStdout
77+ ( const $ Right ()
78+ , handleInit (signalBarrier clientMsgBarrier ()) clientMsgChan
79+ )
80+ (handlers clientMsgChan)
81+ options
82+ Nothing
83+ , void $ waitBarrier clientMsgBarrier
84+ ]
85+ where
86+ handleInit :: IO () -> TChan LSP.FromClientMessage -> LSP.LspFuncs () -> IO (Maybe LSP.ResponseError)
87+ handleInit exitClientMsg clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
88+ Handlers{..} <- getHandlers lspFuncs
89+ let requestHandler' (req, reqId) = requestHandler
90+ (\res -> ResponseMessage "2.0" (responseId reqId) (Just res) Nothing)
91+ (\err -> ResponseMessage "2.0" (responseId reqId) Nothing (Just $ ResponseError err "" Nothing))
92+ req
93+ _ <- flip forkFinally (const exitClientMsg) $ forever $ do
94+ msg <- atomically $ readTChan clientMsgChan
95+ case convClientMsg msg of
96+ Nothing -> Logger.logSeriousError loggerH $ "Unknown client msg: " <> T.pack (show msg)
97+ Just (Left notif) -> notificationHandler notif
98+ Just (Right req) -> sendFunc =<< requestHandler' req
99+ pure Nothing
100+
101+convClientMsg :: LSP.FromClientMessage -> Maybe (Either ServerNotification (ServerRequest, LspId))
102+convClientMsg msg = case msg of
103+ LSP.ReqInitialize m -> unknownReq m
104+ LSP.ReqShutdown m -> Just $ Right (Shutdown, reqId m)
105+
106+ LSP.ReqHover m -> toReq Hover m
107+
108+ LSP.ReqCompletion m -> toReq Completion m
109+ LSP.ReqCompletionItemResolve m -> unknownReq m
110+
111+ LSP.ReqSignatureHelp m -> toReq SignatureHelp m
112+
113+ LSP.ReqDefinition m -> toReq Definition m
114+ LSP.ReqTypeDefinition m -> toReq Definition m
115+ LSP.ReqImplementation m -> toReq Definition m
116+
117+ LSP.ReqFindReferences m -> toReq References m
118+ LSP.ReqDocumentHighlights m -> unknownReq m
119+ LSP.ReqDocumentSymbols m -> toReq DocumentSymbol m
120+ LSP.ReqWorkspaceSymbols m -> toReq WorkspaceSymbol m
121+ LSP.ReqCodeAction m -> unknownReq m
122+
123+ LSP.ReqCodeLens m -> toReq CodeLens m
124+ LSP.ReqCodeLensResolve m -> unknownReq m
125+
126+ LSP.ReqDocumentLink m -> unknownReq m
127+ LSP.ReqDocumentLinkResolve m -> unknownReq m
128+ LSP.ReqDocumentColor m -> unknownReq m
129+ LSP.ReqColorPresentation m -> unknownReq m
130+
131+ LSP.ReqDocumentFormatting m -> toReq Formatting m
132+ LSP.ReqDocumentRangeFormatting m -> unknownReq m
133+ LSP.ReqDocumentOnTypeFormatting m -> unknownReq m
134+
135+ LSP.ReqRename m -> toReq Rename m
136+
137+ LSP.ReqFoldingRange m -> unknownReq m
138+ LSP.ReqExecuteCommand m -> unknownReq m
139+ LSP.ReqWillSaveWaitUntil m -> unknownReq m
140+ LSP.ReqCustomClient m -> case reqMethod m of
141+ CustomClientMethod "daml/keepAlive" -> Just $ Right (KeepAlive, reqId m)
142+ _ -> unknownReq m
143+
144+ LSP.NotInitialized m -> unknownNot m
145+ LSP.NotExit m -> unknownNot m
146+ LSP.NotCancelRequestFromClient m -> unknownNot m
147+ LSP.NotDidChangeConfiguration m -> unknownNot m
148+ LSP.NotDidOpenTextDocument m -> toNot DidOpenTextDocument m
149+ LSP.NotDidChangeTextDocument m -> toNot DidChangeTextDocument m
150+ LSP.NotDidCloseTextDocument m -> toNot DidCloseTextDocument m
151+ LSP.NotWillSaveTextDocument m -> unknownNot m
152+ LSP.NotDidSaveTextDocument m -> toNot DidSaveTextDocument m
153+ LSP.NotDidChangeWatchedFiles m -> unknownNot m
154+ LSP.NotDidChangeWorkspaceFolders m -> unknownNot m
155+ LSP.NotProgressCancel m -> unknownNot m
156+ LSP.NotCustomClient m -> unknownNot m
157+
158+ LSP.RspApplyWorkspaceEdit _ -> Nothing
159+ LSP.RspFromClient _ -> Nothing
160+ where toReq constr msg = Just $ Right (constr $ reqParams msg, reqId msg)
161+ toNot constr msg = Just $ Left $ constr $ notParams msg
162+ unknownReq (LSP.RequestMessage _ id method params) =
163+ Just $ Right (UnknownRequest (TL.toStrict $ Aeson.encodeToLazyText method) (Aeson.toJSON params), id)
164+ unknownNot (LSP.NotificationMessage _ method params) =
165+ Just $ Left $ UnknownNotification (TL.toStrict $ Aeson.encodeToLazyText method) (Aeson.toJSON params)
166+ -- Type-restricted wrappers to make DuplicateRecordFields less annoying.
167+ reqParams :: RequestMessage m req resp -> req
168+ reqParams = _params
169+ reqId :: RequestMessage m req resp -> LspId
170+ reqId = _id
171+ reqMethod :: RequestMessage m req resp -> m
172+ reqMethod = _method
173+ notParams :: NotificationMessage m a -> a
174+ notParams = _params
175+
176+handlers :: TChan LSP.FromClientMessage -> LSP.Handlers
177+handlers chan = def
178+ { LSP.hoverHandler = emit LSP.ReqHover
179+ , LSP.definitionHandler = emit LSP.ReqDefinition
180+ , LSP.codeLensHandler = emit LSP.ReqCodeLens
181+ , LSP.didOpenTextDocumentNotificationHandler = emit LSP.NotDidOpenTextDocument
182+ , LSP.didChangeTextDocumentNotificationHandler = emit LSP.NotDidChangeTextDocument
183+ , LSP.didCloseTextDocumentNotificationHandler = emit LSP.NotDidCloseTextDocument
184+ , LSP.didSaveTextDocumentNotificationHandler = emit LSP.NotDidSaveTextDocument
185+ , LSP.initializedHandler = emit LSP.NotInitialized
186+ , LSP.exitNotificationHandler = Nothing
187+ -- If the exit notification handler is set to `Nothing`
188+ -- haskell-lsp will take care of shutting down the server for us.
189+ , LSP.customRequestHandler = emit LSP.ReqCustomClient
190+ , LSP.cancelNotificationHandler = Just $ const $ pure ()
191+ -- ^ We just ignore cancel requests which is allowed according to
192+ -- the spec. Installing a handler avoids errors about the missing handler.
193+ }
194+ where
195+ emit :: (a -> LSP.FromClientMessage) -> Maybe (LSP.Handler a)
196+ emit f = Just $ atomically . writeTChan chan . f
197+
198+options :: LSP.Options
199+options = def
200+ { LSP.textDocumentSync = Just TextDocumentSyncOptions
201+ { _openClose = Just True
202+ , _change = Just TdSyncIncremental
203+ , _willSave = Nothing
204+ , _willSaveWaitUntil = Nothing
205+ , _save = Just $ SaveOptions $ Just False
206+ }
207+ , LSP.codeLensProvider = Just $ CodeLensOptions $ Just False
208+ }