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   , request
  28   , response
  29   , notification
  30   , loggingNotification
  31   , publishDiagnosticsNotification
  32   -- * Combinators
  33   , choice
  34   , option
  35   , optional
  36   , between
  37   , some
  38   , many
  39   , sepBy
  40   , sepBy1
  41   , sepEndBy1
  42   , sepEndBy
  43   , endBy1
  44   , endBy
  45   , count
  46   , manyTill
  47   , skipMany
  48   , skipSome
  49   , skipManyTill
  50   , skipSomeTill
  51   , (<|>)
  52   , satisfy
  53   -- * Utilities
  54   , openDoc
  55   , getDocItem
  56   , getDocUri
  57   ) where
  58
  59 import Control.Applicative
  60 import Control.Applicative.Combinators
  61 import Control.Monad
  62 import Control.Monad.IO.Class
  63 import Control.Concurrent
  64 import Control.Lens
  65 import qualified Data.Text as T
  66 import qualified Data.Text.IO as T
  67 import Data.Aeson
  68 import qualified Data.ByteString.Lazy.Char8 as B
  69 import Data.Default
  70 import Data.Proxy
  71 import System.Process
  72 import Language.Haskell.LSP.Types
  73 import qualified  Language.Haskell.LSP.Types as LSP (error)
  74 import Language.Haskell.LSP.Messages
  75 import Language.Haskell.LSP.Test.Compat
  76 import System.IO
  77 import System.Directory
  78 import System.FilePath
  79 import Language.Haskell.LSP.Test.Decoding
  80 import Language.Haskell.LSP.Test.Parsing
  81
  82 -- | Starts a new session.
  83 runSession :: FilePath -- ^ The filepath to the server executable.
  84            -> FilePath -- ^ The filepath to the root directory for the session.
  85            -> Session a -- ^ The session to run.
  86            -> IO ()
  87 runSession serverExe 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 serverExe rootDir $ do
  99
 100     -- Wrap the session around initialize and shutdown calls
 101     sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
 102     RspInitialize initRsp <- response
 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                       -> FilePath
 117                       -> Session a
 118                       -> IO a
 119 runSessionWithHandler serverHandler serverExe rootDir session = do
 120   absRootDir <- canonicalizePath rootDir
 121
 122   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
 123     (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
 124     { std_in = CreatePipe, std_out = CreatePipe }
 125
 126   hSetBuffering serverIn  NoBuffering
 127   hSetBuffering serverOut NoBuffering
 128
 129   reqMap <- newMVar newRequestMap
 130   messageChan <- newChan
 131   meaninglessChan <- newChan
 132
 133   let context = SessionContext serverIn absRootDir messageChan reqMap
 134       initState = SessionState (IdInt 9)
 135
 136   forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 137   (result, _) <- runSession' messageChan context initState session
 138
 139   terminateProcess serverProc
 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   :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
 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 :: RequestMessage ClientMethod params resp
 174
 175   sendRequest' req
 176
 177   return id
 178
 179   where nextId (IdInt i) = IdInt (i + 1)
 180         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 181
 182 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 183 sendRequest' req = do
 184   -- Update the request map
 185   reqMap <- requestMap <$> ask
 186   liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
 187
 188   sendMessage req
 189
 190 -- | Sends a notification to the server.
 191 sendNotification :: ToJSON a
 192                  => ClientMethod -- ^ The notification method.
 193                  -> a -- ^ The notification parameters.
 194                  -> Session ()
 195 sendNotification method params =
 196   let notif = NotificationMessage "2.0" method params
 197     in sendNotification' notif
 198
 199 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 200 sendNotification' = sendMessage
 201
 202 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 203 sendResponse = sendMessage
 204
 205 sendMessage :: ToJSON a => a -> Session ()
 206 sendMessage msg = do
 207   h <- serverIn <$> ask
 208   liftIO $ B.hPut h $ addHeader (encode msg)
 209
 210 -- | Opens a text document and sends a notification to the client.
 211 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 212 openDoc file languageId = do
 213   item <- getDocItem file languageId
 214   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 215   TextDocumentIdentifier <$> getDocUri file
 216
 217 -- | Reads in a text document as the first version.
 218 getDocItem :: FilePath -- ^ The path to the text document to read in.
 219            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 220            -> Session TextDocumentItem
 221 getDocItem file languageId = do
 222   context <- ask
 223   let fp = rootDir context </> file
 224   contents <- liftIO $ T.readFile fp
 225   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 226
 227 -- | Gets the Uri for the file corrected to the session directory.
 228 getDocUri :: FilePath -> Session Uri
 229 getDocUri file = do
 230   context <- ask
 231   let fp = rootDir context </> file
 232   return $ filePathToUri fp