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