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   , runSessionWithHandler
  19   , Session
  20   -- * Sending
  21   , sendRequest
  22   , sendNotification
  23   , sendRequest'
  24   , sendNotification'
  25   , sendResponse
  26   -- * Receving
  27   , anyRequest
  28   , request
  29   , anyResponse
  30   , response
  31   , anyNotification
  32   , notification
  33   , loggingNotification
  34   , publishDiagnosticsNotification
  35   -- * Combinators
  36   , choice
  37   , option
  38   , optional
  39   , between
  40   , some
  41   , many
  42   , sepBy
  43   , sepBy1
  44   , sepEndBy1
  45   , sepEndBy
  46   , endBy1
  47   , endBy
  48   , count
  49   , manyTill
  50   , skipMany
  51   , skipSome
  52   , skipManyTill
  53   , skipSomeTill
  54   , (<|>)
  55   , satisfy
  56   -- * Utilities
  57   , getInitializeResponse
  58   , openDoc
  59   , getDocItem
  60   , getDocUri
  61   ) where
  62
  63 import Control.Applicative
  64 import Control.Applicative.Combinators
  65 import Control.Monad
  66 import Control.Monad.IO.Class
  67 import Control.Concurrent
  68 import Control.Lens hiding ((.=))
  69 import qualified Data.Text as T
  70 import qualified Data.Text.IO as T
  71 import Data.Aeson
  72 import qualified Data.ByteString.Lazy.Char8 as B
  73 import Data.Default
  74 import System.Process
  75 import Language.Haskell.LSP.Types
  76 import qualified  Language.Haskell.LSP.Types as LSP (error, id)
  77 import Language.Haskell.LSP.Test.Compat
  78 import System.IO
  79 import System.Directory
  80 import System.FilePath
  81 import Language.Haskell.LSP.Test.Decoding
  82 import Language.Haskell.LSP.Test.Parsing
  83
  84 -- | Starts a new session.
  85 runSession :: String -- ^ The command to run the server.
  86            -> FilePath -- ^ The filepath to the root directory for the session.
  87            -> Session a -- ^ The session to run.
  88            -> IO a
  89 runSession serverExe rootDir session = do
  90   pid <- getProcessID
  91   absRootDir <- canonicalizePath rootDir
  92
  93   let initializeParams = InitializeParams (Just pid)
  94                                           (Just $ T.pack absRootDir)
  95                                           (Just $ filePathToUri absRootDir)
  96                                           Nothing
  97                                           def
  98                                           (Just TraceOff)
  99
 100   runSessionWithHandler listenServer serverExe rootDir $ do
 101
 102     -- Wrap the session around initialize and shutdown calls
 103     sendRequest Initialize initializeParams
 104     initRspMsg <- response :: Session InitializeResponse
 105
 106     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 107
 108     initRspVar <- initRsp <$> ask
 109     liftIO $ putMVar initRspVar initRspMsg
 110
 111
 112     sendNotification Initialized InitializedParams
 113
 114     -- Run the actual test
 115     result <- session
 116
 117     sendNotification Exit ExitParams
 118
 119     return result
 120
 121 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 122 -- It also does not automatically send initialize and exit messages.
 123 runSessionWithHandler :: (Handle -> Session ())
 124                       -> String
 125                       -> FilePath
 126                       -> Session a
 127                       -> IO a
 128 runSessionWithHandler serverHandler serverExe rootDir session = do
 129   absRootDir <- canonicalizePath rootDir
 130
 131   let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
 132   (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc
 133
 134   hSetBuffering serverIn  NoBuffering
 135   hSetBuffering serverOut NoBuffering
 136
 137   reqMap <- newMVar newRequestMap
 138   messageChan <- newChan
 139   meaninglessChan <- newChan
 140   initRsp <- newEmptyMVar
 141
 142   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
 143       initState = SessionState (IdInt 9)
 144
 145   threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 146   (result, _) <- runSession' messageChan context initState session
 147
 148   terminateProcess serverProc
 149   killThread threadId
 150
 151   return result
 152
 153 -- | Listens to the server output, makes sure it matches the record and
 154 -- signals any semaphores
 155 listenServer :: Handle -> Session ()
 156 listenServer serverOut = do
 157   msgBytes <- liftIO $ getNextMessage serverOut
 158
 159   context <- ask
 160   reqMap <- liftIO $ readMVar $ requestMap context
 161
 162   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 163
 164   listenServer serverOut
 165
 166 -- | Sends a request to the server.
 167 --
 168 -- @
 169 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 170 --             TextDocumentDocumentSymbol
 171 --             (DocumentSymbolParams docId)
 172 -- @
 173 sendRequest
 174   :: (ToJSON params)
 175   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 176   ClientMethod -- ^ The request method.
 177   -> params -- ^ The request parameters.
 178   -> Session LspId -- ^ The id of the request that was sent.
 179 sendRequest method params = do
 180   id <- curReqId <$> get
 181   modify $ \c -> c { curReqId = nextId id }
 182
 183   let req = RequestMessage' "2.0" id method params
 184
 185   -- Update the request map
 186   reqMap <- requestMap <$> ask
 187   liftIO $ modifyMVar_ reqMap $
 188     \r -> return $ updateRequestMap r id method
 189
 190   sendMessage req
 191
 192   return id
 193
 194   where nextId (IdInt i) = IdInt (i + 1)
 195         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 196
 197 -- | A custom type for request message that doesn't
 198 -- need a response type, allows us to infer the request
 199 -- message type without using proxies.
 200 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 201
 202 instance ToJSON a => ToJSON (RequestMessage' a) where
 203   toJSON (RequestMessage' rpc id method params) =
 204     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 205
 206
 207 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 208 sendRequest' req = do
 209   -- Update the request map
 210   reqMap <- requestMap <$> ask
 211   liftIO $ modifyMVar_ reqMap $
 212     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 213
 214   sendMessage req
 215
 216 -- | Sends a notification to the server.
 217 sendNotification :: ToJSON a
 218                  => ClientMethod -- ^ The notification method.
 219                  -> a -- ^ The notification parameters.
 220                  -> Session ()
 221 sendNotification method params =
 222   let notif = NotificationMessage "2.0" method params
 223     in sendNotification' notif
 224
 225 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 226 sendNotification' = sendMessage
 227
 228 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 229 sendResponse = sendMessage
 230
 231 sendMessage :: ToJSON a => a -> Session ()
 232 sendMessage msg = do
 233   h <- serverIn <$> ask
 234   liftIO $ B.hPut h $ addHeader (encode msg)
 235
 236 -- | Returns the initialize response that was received from the server.
 237 -- The initialize requests and responses are not included the session,
 238 -- so if you need to test it use this.
 239 getInitializeResponse :: Session InitializeResponse
 240 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 241
 242 -- | Opens a text document and sends a notification to the client.
 243 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 244 openDoc file languageId = do
 245   item <- getDocItem file languageId
 246   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 247   TextDocumentIdentifier <$> getDocUri file
 248
 249 -- | Reads in a text document as the first version.
 250 getDocItem :: FilePath -- ^ The path to the text document to read in.
 251            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 252            -> Session TextDocumentItem
 253 getDocItem file languageId = do
 254   context <- ask
 255   let fp = rootDir context </> file
 256   contents <- liftIO $ T.readFile fp
 257   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 258
 259 -- | Gets the Uri for the file corrected to the session directory.
 260 getDocUri :: FilePath -> Session Uri
 261 getDocUri file = do
 262   context <- ask
 263   let fp = rootDir context </> file
 264   return $ filePathToUri fp