module LSP.Client
(
start
, Config (..)
, RequestMessageHandler (..)
, NotificationMessageHandler (..)
, sendClientRequest
, sendClientNotification
) where
import Prelude
import Control.Lens
import System.IO
import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
import System.Process
import Control.Exception (handle, IOException)
import Control.Monad (forever)
import Control.Concurrent
import qualified Data.IntMap as M
import Data.Proxy (Proxy (Proxy))
import Text.Read (readMaybe)
import Control.Arrow ((&&&))
import System.Exit (exitFailure)
import qualified Data.Text.IO as T
import Control.Exception (SomeException)
data ClientMessage
= forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
=> ClientRequest LSP.ClientMethod params (MVar (Maybe (Either LSP.ResponseError resp)))
| forall params. (ToJSON params)
=> ClientNotification LSP.ClientMethod params
data ResponseVar = forall resp . FromJSON resp =>
ResponseVar (MVar (Maybe (Either LSP.ResponseError resp)))
data Config = Config
{ toServer :: !Handle
, fromServer :: !Handle
, handleNotification :: !NotificationMessageHandler
, handleRequest :: !RequestMessageHandler
}
sendClientRequest
:: forall params resp . (ToJSON params, ToJSON resp, FromJSON resp)
=> Proxy (LSP.RequestMessage LSP.ClientMethod params resp)
-> MVar ClientMessage
-> LSP.ClientMethod
-> params
-> IO (Maybe (Either LSP.ResponseError resp))
sendClientRequest Proxy reqVar method params = do
respVar <- newEmptyMVar :: IO (MVar (Maybe (Either LSP.ResponseError resp)))
putMVar reqVar (ClientRequest method params respVar)
takeMVar respVar
sendClientNotification
:: forall params . (ToJSON params)
=> MVar ClientMessage
-> LSP.ClientMethod
-> params
-> IO ()
sendClientNotification reqVar method params =
putMVar reqVar (ClientNotification method params)
start :: Config -> IO (MVar ClientMessage)
start (Config inp out handleNotification handleRequest) =
handle (\(e :: IOException) -> hPrint stderr e >> exitFailure >> undefined) $ do
hSetBuffering inp NoBuffering
hSetBuffering out NoBuffering
req <- newEmptyMVar :: IO (MVar ClientMessage)
requestMap <- newMVar mempty :: IO (MVar (M.IntMap ResponseVar))
forkIO (receiving handleNotification handleRequest inp out requestMap)
forkIO (sending inp req requestMap)
return req
receiving :: NotificationMessageHandler
-> RequestMessageHandler
-> Handle
-> Handle
-> MVar (M.IntMap ResponseVar)
-> IO ()
receiving handleNotification handleRequest inp out requestMap =
forever $ handle (\(e :: SomeException) -> hPrint stderr e) $ do
headers <- getHeaders out
case lookup "Content-Length" headers >>= readMaybe of
Nothing -> fail "Couldn't read Content-Length header"
Just size -> do
message <- B.hGet out size
case decode message of
Just m -> handleRequestMessage inp handleRequest m
Nothing -> case decode message of
Just m -> handleNotificationMessage handleNotification m
Nothing -> case decode message of
Just m -> handleResponseMessage requestMap m
Nothing -> fail "malformed message"
where
getHeaders :: Handle -> IO [(String,String)]
getHeaders h = do
l <- hGetLine h
let (name,val) = span (/= ':') l
if null val
then return []
else ((name,drop 2 val) :) <$> getHeaders h
sending :: Handle -> MVar ClientMessage -> MVar (M.IntMap ResponseVar) -> IO ()
sending inp req requestMap = forever $ handle (\(e :: SomeException) -> hPrint stderr e) $ do
clientMessage <- takeMVar req
case clientMessage of
(ClientRequest method (req :: req) (respVar :: MVar (Maybe (Either LSP.ResponseError resp)))) -> do
lspId <- head . (\m -> filter (`M.notMember` m) [minBound..]) <$> readMVar requestMap
B.hPutStr inp $ addHeader $ encode
(LSP.RequestMessage "2.0" (LSP.IdInt lspId) method req
:: LSP.RequestMessage LSP.ClientMethod req resp)
modifyMVar_ requestMap $ return . M.insert lspId (ResponseVar respVar)
(ClientNotification method req) ->
B.hPutStr inp (addHeader (encode (LSP.NotificationMessage "2.0" method req)))
addHeader :: B.ByteString -> B.ByteString
addHeader content = B.concat
[ "Content-Length: ", B.pack $ show $ B.length content, "\r\n"
, "\r\n"
, content
]
handleResponseMessage :: MVar (M.IntMap ResponseVar) -> LSP.ResponseMessage Value -> IO ()
handleResponseMessage requestMap = \case
LSP.ResponseMessage _ (LSP.IdRspInt lspId) (Just response) Nothing -> do
mayResVar <- modifyMVar requestMap $ return . (M.delete lspId &&& M.lookup lspId)
case mayResVar of
Nothing -> fail "Server sent us an unknown id of type Int"
Just (ResponseVar resVar) ->
case fromJSON response of
Success result -> putMVar resVar $ Just $ Right result
_ -> putMVar resVar Nothing
LSP.ResponseMessage _ (LSP.IdRspInt lspId) Nothing (Just rspError) -> do
mayResVar <- modifyMVar requestMap $ return . (M.delete lspId &&& M.lookup lspId)
case mayResVar of
Nothing -> fail "Server sent us an unknown id of type Int"
Just (ResponseVar resVar) ->
putMVar resVar $ Just $ Left rspError
LSP.ResponseMessage _ (LSP.IdRspString _) (Just _) Nothing ->
fail "Server sent us an unknown id of type String"
LSP.ResponseMessage _ (LSP.IdRspString _) Nothing (Just _) ->
fail "Server sent us an unknown id of type String"
LSP.ResponseMessage _ LSP.IdRspNull _ _ ->
fail "Server couldn't read our id"
_ -> fail "Malformed message"
data RequestMessageHandler = RequestMessageHandler
{ handleWindowShowMessageRequest :: LSP.ShowMessageRequest -> IO LSP.ShowMessageResponse
, handleClientRegisterCapability :: LSP.RegisterCapabilityRequest -> IO LSP.ErrorResponse
, handleClientUnregisterCapability :: LSP.UnregisterCapabilityRequest -> IO LSP.ErrorResponse
, handleWorkspaceApplyEdit :: LSP.ApplyWorkspaceEditRequest -> IO LSP.ApplyWorkspaceEditResponse
}
handleRequestMessage
:: Handle
-> RequestMessageHandler
-> LSP.RequestMessage LSP.ServerMethod Value Value
-> IO ()
handleRequestMessage inp RequestMessageHandler {..} m = do
resp <- case m ^. LSP.method of
method@LSP.WindowShowMessageRequest ->
case fromJSON (m ^. LSP.params) :: Result LSP.ShowMessageRequestParams of
Success params -> encode <$> handleWindowShowMessageRequest
(LSP.RequestMessage (m ^. LSP.jsonrpc) (m ^. LSP.id) method params)
_ -> fail "Invalid parameters of window/showMessage request."
method@LSP.ClientRegisterCapability ->
case fromJSON (m ^. LSP.params) :: Result LSP.RegistrationParams of
Success params -> encode <$> handleClientRegisterCapability
(LSP.RequestMessage (m ^. LSP.jsonrpc) (m ^. LSP.id) method params)
_ -> fail "Invalid parameters of client/registerCapability request."
method@LSP.ClientUnregisterCapability ->
case fromJSON (m ^. LSP.params) :: Result LSP.UnregistrationParams of
Success params -> encode <$> handleClientUnregisterCapability
(LSP.RequestMessage (m ^. LSP.jsonrpc) (m ^. LSP.id) method params)
_ -> fail "Invalid parameters of client/unregisterCapability request."
method@LSP.WorkspaceApplyEdit ->
case fromJSON (m ^. LSP.params) :: Result LSP.ApplyWorkspaceEditParams of
Success params -> encode <$> handleWorkspaceApplyEdit
(LSP.RequestMessage (m ^. LSP.jsonrpc) (m ^. LSP.id) method params)
_ -> fail "Invalid parameters of workspace/applyEdit request."
_ -> fail "Wrong request method."
B.hPutStr inp $ addHeader resp
data NotificationMessageHandler = NotificationMessageHandler
{ handleWindowShowMessage :: LSP.ShowMessageNotification -> IO ()
, handleWindowLogMessage :: LSP.LogMessageNotification -> IO ()
, handleTelemetryEvent :: LSP.TelemetryNotification -> IO ()
, handleTextDocumentPublishDiagnostics :: LSP.PublishDiagnosticsNotification -> IO ()
}
handleNotificationMessage
:: NotificationMessageHandler
-> LSP.NotificationMessage LSP.ServerMethod Value
-> IO ()
handleNotificationMessage NotificationMessageHandler {..} m =
case m ^. LSP.method of
method@LSP.WindowShowMessage ->
case fromJSON (m ^. LSP.params) :: Result LSP.ShowMessageParams of
Success params -> handleWindowShowMessage
(LSP.NotificationMessage (m ^. LSP.jsonrpc) method params)
_ -> fail "Malformed parameters of window/showMessage notification."
method@LSP.WindowLogMessage ->
case fromJSON (m ^. LSP.params) :: Result LSP.LogMessageParams of
Success params -> handleWindowLogMessage
(LSP.NotificationMessage (m ^. LSP.jsonrpc) method params)
_ -> fail "Malformed parameters of window/logMessage notification."
LSP.TelemetryEvent -> handleTelemetryEvent m
method@LSP.TextDocumentPublishDiagnostics ->
case fromJSON (m ^. LSP.params) :: Result LSP.PublishDiagnosticsParams of
Success params -> handleTextDocumentPublishDiagnostics
(LSP.NotificationMessage (m ^. LSP.jsonrpc) method params)
_ -> fail "Malformed parameters of textDocument/publishDiagnostics notification."
_ -> fail $ "unknown method: " ++ show (m ^. LSP.method)