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   forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 136   (result, _) <- runSession' messageChan context initState session
 137
 138   terminateProcess serverProc
 139
 140   return result
 141
 142 -- | Listens to the server output, makes sure it matches the record and
 143 -- signals any semaphores
 144 listenServer :: Handle -> Session ()
 145 listenServer serverOut = do
 146   msgBytes <- liftIO $ getNextMessage serverOut
 147
 148   context <- ask
 149   reqMap <- liftIO $ readMVar $ requestMap context
 150
 151   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 152
 153   listenServer serverOut
 154
 155 -- | Sends a request to the server.
 156 --
 157 -- @
 158 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 159 --             TextDocumentDocumentSymbol
 160 --             (DocumentSymbolParams docId)
 161 -- @
 162 sendRequest
 163   :: (ToJSON params)
 164   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 165   ClientMethod -- ^ The request method.
 166   -> params -- ^ The request parameters.
 167   -> Session LspId -- ^ The id of the request that was sent.
 168 sendRequest method params = do
 169   id <- curReqId <$> get
 170   modify $ \c -> c { curReqId = nextId id }
 171
 172   let req = RequestMessage' "2.0" id method params
 173
 174   -- Update the request map
 175   reqMap <- requestMap <$> ask
 176   liftIO $ modifyMVar_ reqMap $
 177     \r -> return $ updateRequestMap r id method
 178
 179   sendMessage req
 180
 181   return id
 182
 183   where nextId (IdInt i) = IdInt (i + 1)
 184         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 185
 186 -- | A custom type for request message that doesn't
 187 -- need a response type, allows us to infer the request
 188 -- message type without using proxies.
 189 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 190
 191 instance ToJSON a => ToJSON (RequestMessage' a) where
 192   toJSON (RequestMessage' rpc id method params) =
 193     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 194
 195
 196 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 197 sendRequest' req = do
 198   -- Update the request map
 199   reqMap <- requestMap <$> ask
 200   liftIO $ modifyMVar_ reqMap $
 201     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 202
 203   sendMessage req
 204
 205 -- | Sends a notification to the server.
 206 sendNotification :: ToJSON a
 207                  => ClientMethod -- ^ The notification method.
 208                  -> a -- ^ The notification parameters.
 209                  -> Session ()
 210 sendNotification method params =
 211   let notif = NotificationMessage "2.0" method params
 212     in sendNotification' notif
 213
 214 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 215 sendNotification' = sendMessage
 216
 217 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 218 sendResponse = sendMessage
 219
 220 sendMessage :: ToJSON a => a -> Session ()
 221 sendMessage msg = do
 222   h <- serverIn <$> ask
 223   liftIO $ B.hPut h $ addHeader (encode msg)
 224
 225 -- | Opens a text document and sends a notification to the client.
 226 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 227 openDoc file languageId = do
 228   item <- getDocItem file languageId
 229   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 230   TextDocumentIdentifier <$> getDocUri file
 231
 232 -- | Reads in a text document as the first version.
 233 getDocItem :: FilePath -- ^ The path to the text document to read in.
 234            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 235            -> Session TextDocumentItem
 236 getDocItem file languageId = do
 237   context <- ask
 238   let fp = rootDir context </> file
 239   contents <- liftIO $ T.readFile fp
 240   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 241
 242 -- | Gets the Uri for the file corrected to the session directory.
 243 getDocUri :: FilePath -> Session Uri
 244 getDocUri file = do
 245   context <- ask
 246   let fp = rootDir context </> file
 247   return $ filePathToUri fp