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