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   , openDoc
  58   , getDocItem
  59   , getDocUri
  60   ) where
  61
  62 import Control.Applicative
  63 import Control.Applicative.Combinators
  64 import Control.Monad
  65 import Control.Monad.IO.Class
  66 import Control.Concurrent
  67 import Control.Lens hiding ((.=))
  68 import qualified Data.Text as T
  69 import qualified Data.Text.IO as T
  70 import Data.Aeson
  71 import qualified Data.ByteString.Lazy.Char8 as B
  72 import Data.Default
  73 import System.Process
  74 import Language.Haskell.LSP.Types
  75 import qualified  Language.Haskell.LSP.Types as LSP (error, id)
  76 import Language.Haskell.LSP.Test.Compat
  77 import System.IO
  78 import System.Directory
  79 import System.FilePath
  80 import Language.Haskell.LSP.Test.Decoding
  81 import Language.Haskell.LSP.Test.Parsing
  82
  83 -- | Starts a new session.
  84 runSession :: FilePath -- ^ The filepath to the server executable.
  85            -> FilePath -- ^ The filepath to the root directory for the session.
  86            -> Session a -- ^ The session to run.
  87            -> IO ()
  88 runSession serverExe rootDir session = do
  89   pid <- getProcessID
  90   absRootDir <- canonicalizePath rootDir
  91
  92   let initializeParams = InitializeParams (Just pid)
  93                                           (Just $ T.pack absRootDir)
  94                                           (Just $ filePathToUri absRootDir)
  95                                           Nothing
  96                                           def
  97                                           (Just TraceOff)
  98
  99   runSessionWithHandler listenServer serverExe rootDir $ do
 100
 101     -- Wrap the session around initialize and shutdown calls
 102     sendRequest Initialize initializeParams
 103     initRsp <- response :: Session InitializeResponse
 104     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 105
 106     sendNotification Initialized InitializedParams
 107
 108     -- Run the actual test
 109     session
 110
 111     sendNotification Exit ExitParams
 112
 113 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 114 -- It also does not automatically send initialize and exit messages.
 115 runSessionWithHandler :: (Handle -> Session ())
 116                       -> FilePath
 117                       -> FilePath
 118                       -> Session a
 119                       -> IO a
 120 runSessionWithHandler serverHandler serverExe rootDir session = do
 121   absRootDir <- canonicalizePath rootDir
 122
 123   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
 124     (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
 125     { std_in = CreatePipe, std_out = CreatePipe }
 126
 127   hSetBuffering serverIn  NoBuffering
 128   hSetBuffering serverOut NoBuffering
 129
 130   reqMap <- newMVar newRequestMap
 131   messageChan <- newChan
 132   meaninglessChan <- newChan
 133
 134   let context = SessionContext serverIn absRootDir messageChan reqMap
 135       initState = SessionState (IdInt 9)
 136
 137   threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 138   (result, _) <- runSession' messageChan context initState session
 139
 140   terminateProcess serverProc
 141   killThread threadId
 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   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 155
 156   listenServer serverOut
 157
 158 -- | Sends a request to the server.
 159 --
 160 -- @
 161 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 162 --             TextDocumentDocumentSymbol
 163 --             (DocumentSymbolParams docId)
 164 -- @
 165 sendRequest
 166   :: (ToJSON params)
 167   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 168   ClientMethod -- ^ The request method.
 169   -> params -- ^ The request parameters.
 170   -> Session LspId -- ^ The id of the request that was sent.
 171 sendRequest method params = do
 172   id <- curReqId <$> get
 173   modify $ \c -> c { curReqId = nextId id }
 174
 175   let req = RequestMessage' "2.0" id method params
 176
 177   -- Update the request map
 178   reqMap <- requestMap <$> ask
 179   liftIO $ modifyMVar_ reqMap $
 180     \r -> return $ updateRequestMap r id method
 181
 182   sendMessage req
 183
 184   return id
 185
 186   where nextId (IdInt i) = IdInt (i + 1)
 187         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 188
 189 -- | A custom type for request message that doesn't
 190 -- need a response type, allows us to infer the request
 191 -- message type without using proxies.
 192 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 193
 194 instance ToJSON a => ToJSON (RequestMessage' a) where
 195   toJSON (RequestMessage' rpc id method params) =
 196     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 197
 198
 199 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 200 sendRequest' req = do
 201   -- Update the request map
 202   reqMap <- requestMap <$> ask
 203   liftIO $ modifyMVar_ reqMap $
 204     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 205
 206   sendMessage req
 207
 208 -- | Sends a notification to the server.
 209 sendNotification :: ToJSON a
 210                  => ClientMethod -- ^ The notification method.
 211                  -> a -- ^ The notification parameters.
 212                  -> Session ()
 213 sendNotification method params =
 214   let notif = NotificationMessage "2.0" method params
 215     in sendNotification' notif
 216
 217 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 218 sendNotification' = sendMessage
 219
 220 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 221 sendResponse = sendMessage
 222
 223 sendMessage :: ToJSON a => a -> Session ()
 224 sendMessage msg = do
 225   h <- serverIn <$> ask
 226   liftIO $ B.hPut h $ addHeader (encode msg)
 227
 228 -- | Opens a text document and sends a notification to the client.
 229 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 230 openDoc file languageId = do
 231   item <- getDocItem file languageId
 232   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 233   TextDocumentIdentifier <$> getDocUri file
 234
 235 -- | Reads in a text document as the first version.
 236 getDocItem :: FilePath -- ^ The path to the text document to read in.
 237            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 238            -> Session TextDocumentItem
 239 getDocItem file languageId = do
 240   context <- ask
 241   let fp = rootDir context </> file
 242   contents <- liftIO $ T.readFile fp
 243   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 244
 245 -- | Gets the Uri for the file corrected to the session directory.
 246 getDocUri :: FilePath -> Session Uri
 247 getDocUri file = do
 248   context <- ask
 249   let fp = rootDir context </> file
 250   return $ filePathToUri fp