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 ()
  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     session
 116
 117     sendNotification Exit ExitParams
 118
 119 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 120 -- It also does not automatically send initialize and exit messages.
 121 runSessionWithHandler :: (Handle -> Session ())
 122                       -> String
 123                       -> FilePath
 124                       -> Session a
 125                       -> IO a
 126 runSessionWithHandler serverHandler serverExe rootDir session = do
 127   absRootDir <- canonicalizePath rootDir
 128
 129   let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
 130   (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc
 131
 132   hSetBuffering serverIn  NoBuffering
 133   hSetBuffering serverOut NoBuffering
 134
 135   reqMap <- newMVar newRequestMap
 136   messageChan <- newChan
 137   meaninglessChan <- newChan
 138   initRsp <- newEmptyMVar
 139
 140   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
 141       initState = SessionState (IdInt 9)
 142
 143   threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 144   (result, _) <- runSession' messageChan context initState session
 145
 146   terminateProcess serverProc
 147   killThread threadId
 148
 149   return result
 150
 151 -- | Listens to the server output, makes sure it matches the record and
 152 -- signals any semaphores
 153 listenServer :: Handle -> Session ()
 154 listenServer serverOut = do
 155   msgBytes <- liftIO $ getNextMessage serverOut
 156
 157   context <- ask
 158   reqMap <- liftIO $ readMVar $ requestMap context
 159
 160   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 161
 162   listenServer serverOut
 163
 164 -- | Sends a request to the server.
 165 --
 166 -- @
 167 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 168 --             TextDocumentDocumentSymbol
 169 --             (DocumentSymbolParams docId)
 170 -- @
 171 sendRequest
 172   :: (ToJSON params)
 173   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 174   ClientMethod -- ^ The request method.
 175   -> params -- ^ The request parameters.
 176   -> Session LspId -- ^ The id of the request that was sent.
 177 sendRequest method params = do
 178   id <- curReqId <$> get
 179   modify $ \c -> c { curReqId = nextId id }
 180
 181   let req = RequestMessage' "2.0" id method params
 182
 183   -- Update the request map
 184   reqMap <- requestMap <$> ask
 185   liftIO $ modifyMVar_ reqMap $
 186     \r -> return $ updateRequestMap r id method
 187
 188   sendMessage req
 189
 190   return id
 191
 192   where nextId (IdInt i) = IdInt (i + 1)
 193         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 194
 195 -- | A custom type for request message that doesn't
 196 -- need a response type, allows us to infer the request
 197 -- message type without using proxies.
 198 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 199
 200 instance ToJSON a => ToJSON (RequestMessage' a) where
 201   toJSON (RequestMessage' rpc id method params) =
 202     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 203
 204
 205 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 206 sendRequest' req = do
 207   -- Update the request map
 208   reqMap <- requestMap <$> ask
 209   liftIO $ modifyMVar_ reqMap $
 210     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 211
 212   sendMessage req
 213
 214 -- | Sends a notification to the server.
 215 sendNotification :: ToJSON a
 216                  => ClientMethod -- ^ The notification method.
 217                  -> a -- ^ The notification parameters.
 218                  -> Session ()
 219 sendNotification method params =
 220   let notif = NotificationMessage "2.0" method params
 221     in sendNotification' notif
 222
 223 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 224 sendNotification' = sendMessage
 225
 226 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 227 sendResponse = sendMessage
 228
 229 sendMessage :: ToJSON a => a -> Session ()
 230 sendMessage msg = do
 231   h <- serverIn <$> ask
 232   liftIO $ B.hPut h $ addHeader (encode msg)
 233
 234 -- | Returns the initialize response that was received from the server.
 235 -- The initialize requests and responses are not included the session,
 236 -- so if you need to test it use this.
 237 getInitializeResponse :: Session InitializeResponse
 238 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 239
 240 -- | Opens a text document and sends a notification to the client.
 241 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 242 openDoc file languageId = do
 243   item <- getDocItem file languageId
 244   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 245   TextDocumentIdentifier <$> getDocUri file
 246
 247 -- | Reads in a text document as the first version.
 248 getDocItem :: FilePath -- ^ The path to the text document to read in.
 249            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 250            -> Session TextDocumentItem
 251 getDocItem file languageId = do
 252   context <- ask
 253   let fp = rootDir context </> file
 254   contents <- liftIO $ T.readFile fp
 255   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 256
 257 -- | Gets the Uri for the file corrected to the session directory.
 258 getDocUri :: FilePath -> Session Uri
 259 getDocUri file = do
 260   context <- ask
 261   let fp = rootDir context </> file
 262   return $ filePathToUri fp