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