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