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