src/Language/Haskell/LSP/Test.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE ExistentialQuantification #-}
   5
   6 -- |
   7 -- Module      : Language.Haskell.LSP.Test
   8 -- Description : A functional testing framework for LSP servers.
   9 -- Maintainer  : luke_lau@icloud.com
  10 -- Stability   : experimental
  11 --
  12 -- A framework for testing <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers> at the JSON level.
  13
  14 module Language.Haskell.LSP.Test
  15   (
  16   -- * Sessions
  17     runSession
  18   , runSessionWithHandles
  19   , runSessionWithConfig
  20   , Session
  21   , SessionConfig(..)
  22   , MonadSessionConfig(..)
  23   , SessionException(..)
  24   , anySessionException
  25   , withTimeout
  26   -- * Sending
  27   , sendRequest
  28   , sendRequest_
  29   , sendRequest'
  30   , sendNotification
  31   , sendRequestMessage
  32   , sendNotification'
  33   , sendResponse
  34   -- * Receving
  35   , message
  36   , anyRequest
  37   , anyResponse
  38   , anyNotification
  39   , anyMessage
  40   , loggingNotification
  41   , publishDiagnosticsNotification
  42   -- * Combinators
  43   , choice
  44   , option
  45   , optional
  46   , between
  47   , some
  48   , many
  49   , sepBy
  50   , sepBy1
  51   , sepEndBy1
  52   , sepEndBy
  53   , endBy1
  54   , endBy
  55   , count
  56   , manyTill
  57   , skipMany
  58   , skipSome
  59   , skipManyTill
  60   , skipSomeTill
  61   , (<|>)
  62   , satisfy
  63   -- * Utilities
  64   , initializeResponse
  65   -- ** Documents
  66   , openDoc
  67   , documentContents
  68   , getDocumentEdit
  69   , getDocUri
  70   -- ** Symbols
  71   , getDocumentSymbols
  72   -- ** Diagnostics
  73   , waitForDiagnostics
  74   , noDiagnostics
  75   -- ** Commands
  76   , executeCommand
  77   -- ** Code Actions
  78   , getAllCodeActions
  79   , executeCodeAction
  80   ) where
  81
  82 import Control.Applicative
  83 import Control.Applicative.Combinators
  84 import Control.Concurrent
  85 import Control.Monad
  86 import Control.Monad.IO.Class
  87 import Control.Exception
  88 import Control.Lens hiding ((.=), List)
  89 import qualified Data.Text as T
  90 import qualified Data.Text.IO as T
  91 import Data.Aeson
  92 import Data.Default
  93 import qualified Data.HashMap.Strict as HashMap
  94 import qualified Data.Map as Map
  95 import Data.Maybe
  96 import Language.Haskell.LSP.Types hiding (id, capabilities, message)
  97 import qualified Language.Haskell.LSP.Types as LSP
  98 import Language.Haskell.LSP.Messages
  99 import Language.Haskell.LSP.VFS
 100 import Language.Haskell.LSP.Test.Compat
 101 import Language.Haskell.LSP.Test.Decoding
 102 import Language.Haskell.LSP.Test.Exceptions
 103 import Language.Haskell.LSP.Test.Parsing
 104 import Language.Haskell.LSP.Test.Session
 105 import Language.Haskell.LSP.Test.Server
 106 import System.IO
 107 import System.Directory
 108 import System.FilePath
 109 import qualified Yi.Rope as Rope
 110
 111 -- | Starts a new session.
 112 runSession :: String -- ^ The command to run the server.
 113            -> FilePath -- ^ The filepath to the root directory for the session.
 114            -> Session a -- ^ The session to run.
 115            -> IO a
 116 runSession = runSessionWithConfig def
 117
 118 -- | Starts a new sesion with a client with the specified capabilities.
 119 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
 120                      -> String -- ^ The command to run the server.
 121                      -> FilePath -- ^ The filepath to the root directory for the session.
 122                      -> Session a -- ^ The session to run.
 123                      -> IO a
 124 runSessionWithConfig config serverExe rootDir session = do
 125   pid <- getCurrentProcessID
 126   absRootDir <- canonicalizePath rootDir
 127
 128   let initializeParams = InitializeParams (Just pid)
 129                                           (Just $ T.pack absRootDir)
 130                                           (Just $ filePathToUri absRootDir)
 131                                           Nothing
 132                                           (capabilities config)
 133                                           (Just TraceOff)
 134   withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
 135     runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
 136
 137       -- Wrap the session around initialize and shutdown calls
 138       initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
 139
 140       liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 141
 142       initRspVar <- initRsp <$> ask
 143       liftIO $ putMVar initRspVar initRspMsg
 144
 145       sendNotification Initialized InitializedParams
 146
 147       -- Run the actual test
 148       result <- session
 149
 150       sendNotification Exit ExitParams
 151
 152       return result
 153   where
 154   -- | Listens to the server output, makes sure it matches the record and
 155   -- signals any semaphores
 156   listenServer :: Handle -> SessionContext -> IO ()
 157   listenServer serverOut context = do
 158     msgBytes <- getNextMessage serverOut
 159
 160     reqMap <- readMVar $ requestMap context
 161
 162     let msg = decodeFromServerMsg reqMap msgBytes
 163     writeChan (messageChan context) (ServerMessage msg)
 164
 165     listenServer serverOut context
 166
 167 -- | The current text contents of a document.
 168 documentContents :: TextDocumentIdentifier -> Session T.Text
 169 documentContents doc = do
 170   vfs <- vfs <$> get
 171   let file = vfs Map.! (doc ^. uri)
 172   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 173
 174 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 175 -- and returns the new content
 176 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 177 getDocumentEdit doc = do
 178   req <- message :: Session ApplyWorkspaceEditRequest
 179
 180   unless (checkDocumentChanges req || checkChanges req) $
 181     liftIO $ throw (IncorrectApplyEditRequestException (show req))
 182
 183   documentContents doc
 184   where
 185     checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
 186     checkDocumentChanges req =
 187       let changes = req ^. params . edit . documentChanges
 188           maybeDocs = fmap (fmap (^. textDocument . uri)) changes
 189       in case maybeDocs of
 190         Just docs -> (doc ^. uri) `elem` docs
 191         Nothing -> False
 192     checkChanges :: ApplyWorkspaceEditRequest -> Bool
 193     checkChanges req =
 194       let mMap = req ^. params . edit . changes
 195         in maybe False (HashMap.member (doc ^. uri)) mMap
 196
 197 -- | Sends a request to the server and waits for its response.
 198 -- @
 199 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
 200 -- @
 201 -- Note: will skip any messages in between the request and the response.
 202 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
 203 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
 204
 205 -- | Send a request to the server and wait for its response,
 206 -- but discard it.
 207 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
 208 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
 209
 210 -- | Sends a request to the server without waiting on the response.
 211 sendRequest'
 212   :: ToJSON params
 213   => ClientMethod -- ^ The request method.
 214   -> params -- ^ The request parameters.
 215   -> Session LspId -- ^ The id of the request that was sent.
 216 sendRequest' method params = do
 217   id <- curReqId <$> get
 218   modify $ \c -> c { curReqId = nextId id }
 219
 220   let req = RequestMessage' "2.0" id method params
 221
 222   -- Update the request map
 223   reqMap <- requestMap <$> ask
 224   liftIO $ modifyMVar_ reqMap $
 225     \r -> return $ updateRequestMap r id method
 226
 227   sendMessage req
 228
 229   return id
 230
 231   where nextId (IdInt i) = IdInt (i + 1)
 232         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 233
 234 -- | A custom type for request message that doesn't
 235 -- need a response type, allows us to infer the request
 236 -- message type without using proxies.
 237 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 238
 239 instance ToJSON a => ToJSON (RequestMessage' a) where
 240   toJSON (RequestMessage' rpc id method params) =
 241     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 242
 243
 244 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 245 sendRequestMessage req = do
 246   -- Update the request map
 247   reqMap <- requestMap <$> ask
 248   liftIO $ modifyMVar_ reqMap $
 249     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 250
 251   sendMessage req
 252
 253 -- | Sends a notification to the server.
 254 sendNotification :: ToJSON a
 255                  => ClientMethod -- ^ The notification method.
 256                  -> a -- ^ The notification parameters.
 257                  -> Session ()
 258
 259 -- | Open a virtual file if we send a did open text document notification
 260 sendNotification TextDocumentDidOpen params = do
 261   let params' = fromJust $ decode $ encode params
 262       n :: DidOpenTextDocumentNotification
 263       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 264   oldVFS <- vfs <$> get
 265   newVFS <- liftIO $ openVFS oldVFS n
 266   modify (\s -> s { vfs = newVFS })
 267   sendNotification' n
 268
 269 -- | Close a virtual file if we send a close text document notification
 270 sendNotification TextDocumentDidClose params = do
 271   let params' = fromJust $ decode $ encode params
 272       n :: DidCloseTextDocumentNotification
 273       n = NotificationMessage "2.0" TextDocumentDidClose params'
 274   oldVFS <- vfs <$> get
 275   newVFS <- liftIO $ closeVFS oldVFS n
 276   modify (\s -> s { vfs = newVFS })
 277   sendNotification' n
 278
 279 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 280
 281 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 282 sendNotification' = sendMessage
 283
 284 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 285 sendResponse = sendMessage
 286
 287 -- | Returns the initialize response that was received from the server.
 288 -- The initialize requests and responses are not included the session,
 289 -- so if you need to test it use this.
 290 initializeResponse :: Session InitializeResponse
 291 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 292
 293 -- | Opens a text document and sends a notification to the client.
 294 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 295 openDoc file languageId = do
 296   item <- getDocItem file languageId
 297   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 298   TextDocumentIdentifier <$> getDocUri file
 299   where
 300   -- | Reads in a text document as the first version.
 301   getDocItem :: FilePath -- ^ The path to the text document to read in.
 302             -> String -- ^ The language ID, e.g "haskell" for .hs files.
 303             -> Session TextDocumentItem
 304   getDocItem file languageId = do
 305     context <- ask
 306     let fp = rootDir context </> file
 307     contents <- liftIO $ T.readFile fp
 308     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 309
 310 -- | Gets the Uri for the file corrected to the session directory.
 311 getDocUri :: FilePath -> Session Uri
 312 getDocUri file = do
 313   context <- ask
 314   let fp = rootDir context </> file
 315   return $ filePathToUri fp
 316
 317 waitForDiagnostics :: Session [Diagnostic]
 318 waitForDiagnostics = do
 319   diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
 320   let (List diags) = diagsNot ^. params . LSP.diagnostics
 321   return diags
 322
 323 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 324 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
 325 -- returned.
 326 noDiagnostics :: Session ()
 327 noDiagnostics = do
 328   diagsNot <- message :: Session PublishDiagnosticsNotification
 329   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
 330
 331 -- | Returns the symbols in a document.
 332 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
 333 getDocumentSymbols doc = do
 334   ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 335   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
 336   let (Just (List symbols)) = mRes
 337   return symbols
 338
 339 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
 340 getAllCodeActions doc = do
 341   curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 342   let ctx = CodeActionContext (List curDiags) Nothing
 343
 344   foldM (go ctx) [] curDiags
 345
 346   where
 347     go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
 348     go ctx acc diag = do
 349       ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 350
 351       case mErr of
 352         Just e -> throw (UnexpectedResponseError rspLid e)
 353         Nothing ->
 354           let Just (List cmdOrCAs) = mRes
 355             in return (acc ++ cmdOrCAs)
 356
 357 executeCommand :: Command -> Session ()
 358 executeCommand cmd = do
 359   let args = decode $ encode $ fromJust $ cmd ^. arguments
 360       execParams = ExecuteCommandParams (cmd ^. command) args
 361   sendRequest_ WorkspaceExecuteCommand execParams
 362
 363 executeCodeAction :: CodeAction -> Session ()
 364 executeCodeAction action = do
 365   maybe (return ()) handleEdit $ action ^. edit
 366   maybe (return ()) executeCommand $ action ^. command
 367
 368   where handleEdit :: WorkspaceEdit -> Session ()
 369         handleEdit e =
 370           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 371             in updateState (ReqApplyWorkspaceEdit req)