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 (logStdErr config) $ \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 file = vfs Map.! (doc ^. uri)
 164   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 165
 166 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 167 -- and returns the new content
 168 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 169 getDocumentEdit doc = do
 170   req <- request :: Session ApplyWorkspaceEditRequest
 171
 172   unless (checkDocumentChanges req || checkChanges req) $
 173     liftIO $ throw (IncorrectApplyEditRequestException (show req))
 174
 175   documentContents doc
 176   where
 177     checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
 178     checkDocumentChanges req =
 179       let changes = req ^. params . edit . documentChanges
 180           maybeDocs = fmap (fmap (^. textDocument . uri)) changes
 181       in case maybeDocs of
 182         Just docs -> (doc ^. uri) `elem` docs
 183         Nothing -> False
 184     checkChanges :: ApplyWorkspaceEditRequest -> Bool
 185     checkChanges req =
 186       let mMap = req ^. params . edit . changes
 187         in maybe False (HashMap.member (doc ^. uri)) mMap
 188
 189 -- | Sends a request to the server.
 190 --
 191 -- @
 192 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 193 --             TextDocumentDocumentSymbol
 194 --             (DocumentSymbolParams docId)
 195 -- @
 196 sendRequest
 197   :: (ToJSON params)
 198   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 199   ClientMethod -- ^ The request method.
 200   -> params -- ^ The request parameters.
 201   -> Session LspId -- ^ The id of the request that was sent.
 202 sendRequest method params = do
 203   id <- curReqId <$> get
 204   modify $ \c -> c { curReqId = nextId id }
 205
 206   let req = RequestMessage' "2.0" id method params
 207
 208   -- Update the request map
 209   reqMap <- requestMap <$> ask
 210   liftIO $ modifyMVar_ reqMap $
 211     \r -> return $ updateRequestMap r id method
 212
 213   sendMessage req
 214
 215   return id
 216
 217   where nextId (IdInt i) = IdInt (i + 1)
 218         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 219
 220 -- | A custom type for request message that doesn't
 221 -- need a response type, allows us to infer the request
 222 -- message type without using proxies.
 223 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 224
 225 instance ToJSON a => ToJSON (RequestMessage' a) where
 226   toJSON (RequestMessage' rpc id method params) =
 227     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 228
 229
 230 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 231 sendRequest' req = do
 232   -- Update the request map
 233   reqMap <- requestMap <$> ask
 234   liftIO $ modifyMVar_ reqMap $
 235     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 236
 237   sendMessage req
 238
 239 -- | Sends a notification to the server.
 240 sendNotification :: ToJSON a
 241                  => ClientMethod -- ^ The notification method.
 242                  -> a -- ^ The notification parameters.
 243                  -> Session ()
 244
 245 -- | Open a virtual file if we send a did open text document notification
 246 sendNotification TextDocumentDidOpen params = do
 247   let params' = fromJust $ decode $ encode params
 248       n :: DidOpenTextDocumentNotification
 249       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 250   oldVFS <- vfs <$> get
 251   newVFS <- liftIO $ openVFS oldVFS n
 252   modify (\s -> s { vfs = newVFS })
 253   sendNotification' n
 254
 255 -- | Close a virtual file if we send a close text document notification
 256 sendNotification TextDocumentDidClose params = do
 257   let params' = fromJust $ decode $ encode params
 258       n :: DidCloseTextDocumentNotification
 259       n = NotificationMessage "2.0" TextDocumentDidClose params'
 260   oldVFS <- vfs <$> get
 261   newVFS <- liftIO $ closeVFS oldVFS n
 262   modify (\s -> s { vfs = newVFS })
 263   sendNotification' n
 264
 265 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 266
 267 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 268 sendNotification' = sendMessage
 269
 270 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 271 sendResponse = sendMessage
 272
 273 sendMessage :: ToJSON a => a -> Session ()
 274 sendMessage msg = do
 275   h <- serverIn <$> ask
 276   liftIO $ B.hPut h $ addHeader (encode msg)
 277
 278 -- | Returns the initialize response that was received from the server.
 279 -- The initialize requests and responses are not included the session,
 280 -- so if you need to test it use this.
 281 initializeResponse :: Session InitializeResponse
 282 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 283
 284 -- | Opens a text document and sends a notification to the client.
 285 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 286 openDoc file languageId = do
 287   item <- getDocItem file languageId
 288   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 289   TextDocumentIdentifier <$> getDocUri file
 290   where
 291   -- | Reads in a text document as the first version.
 292   getDocItem :: FilePath -- ^ The path to the text document to read in.
 293             -> String -- ^ The language ID, e.g "haskell" for .hs files.
 294             -> Session TextDocumentItem
 295   getDocItem file languageId = do
 296     context <- ask
 297     let fp = rootDir context </> file
 298     contents <- liftIO $ T.readFile fp
 299     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 300
 301 -- | Gets the Uri for the file corrected to the session directory.
 302 getDocUri :: FilePath -> Session Uri
 303 getDocUri file = do
 304   context <- ask
 305   let fp = rootDir context </> file
 306   return $ filePathToUri fp
 307
 308 getDiagnostics :: Session [Diagnostic]
 309 getDiagnostics = do
 310   diagsNot <- notification :: Session PublishDiagnosticsNotification
 311   let (List diags) = diagsNot ^. params . LSP.diagnostics
 312   return diags
 313
 314 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 315 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
 316 -- returned.
 317 noDiagnostics :: Session ()
 318 noDiagnostics = do
 319   diagsNot <- notification :: Session PublishDiagnosticsNotification
 320   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
 321
 322 -- | Returns the symbols in a document.
 323 getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
 324 getDocumentSymbols doc = do
 325   sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 326   response