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   -- * Combinators
  32   , choice
  33   , option
  34   , optional
  35   , skipOptional
  36   , between
  37   , some
  38   , many
  39   , sepBy
  40   , sepBy1
  41   , sepByNonEmpty
  42   , sepEndBy1
  43   , sepEndByNonEmpty
  44   , sepEndBy
  45   , endBy1
  46   , endByNonEmpty
  47   , endBy
  48   , count
  49   , chainl
  50   , chainr
  51   , chainl1
  52   , chainr1
  53   , manyTill
  54   , try
  55   , (<?>)
  56   , skipMany
  57   , skipSome
  58   , unexpected
  59   , notFollowedBy
  60   , (<|>)
  61   , satisfy
  62   -- * Utilities
  63   , getDocItem
  64   , getDocUri
  65   ) where
  66
  67 import Control.Applicative
  68 import Control.Monad
  69 import Control.Monad.IO.Class
  70 import Control.Concurrent
  71 import Control.Lens
  72 import qualified Data.Text as T
  73 import qualified Data.Text.IO as T
  74 import Data.Aeson
  75 import qualified Data.ByteString.Lazy.Char8 as B
  76 import Data.Default
  77 import Data.Proxy
  78 import System.Process
  79 import Language.Haskell.LSP.Types
  80 import qualified  Language.Haskell.LSP.Types as LSP (error)
  81 import Language.Haskell.LSP.Messages
  82 import Language.Haskell.LSP.Test.Compat
  83 import System.IO
  84 import System.Directory
  85 import System.FilePath
  86 import Language.Haskell.LSP.Test.Decoding
  87 import Language.Haskell.LSP.Test.Parsing
  88 import Text.Parser.Combinators
  89
  90 -- | Starts a new session.
  91 runSession :: FilePath -- ^ The filepath to the root directory for the session.
  92            -> Session a -- ^ The session to run.
  93            -> IO ()
  94 runSession rootDir session = do
  95   pid <- getProcessID
  96   absRootDir <- canonicalizePath rootDir
  97
  98   let initializeParams = InitializeParams (Just pid)
  99                                           (Just $ T.pack absRootDir)
 100                                           (Just $ filePathToUri absRootDir)
 101                                           Nothing
 102                                           def
 103                                           (Just TraceOff)
 104
 105   runSessionWithHandler listenServer rootDir $ do
 106
 107     -- Wrap the session around initialize and shutdown calls
 108     sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
 109     RspInitialize initRsp <- response
 110     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 111
 112     sendNotification Initialized InitializedParams
 113
 114     -- Run the actual test
 115     session
 116
 117     sendNotification Exit ExitParams
 118
 119 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 120 -- It also does not automatically send initialize and exit messages.
 121 runSessionWithHandler :: (Handle -> Session ())
 122                       -> FilePath
 123                       -> Session a
 124                       -> IO a
 125 runSessionWithHandler serverHandler rootDir session = do
 126   absRootDir <- canonicalizePath rootDir
 127
 128   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
 129     (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
 130     { std_in = CreatePipe, std_out = CreatePipe }
 131
 132   hSetBuffering serverIn  NoBuffering
 133   hSetBuffering serverOut NoBuffering
 134
 135   reqMap <- newMVar newRequestMap
 136   messageChan <- newChan
 137   meaninglessChan <- newChan
 138
 139   let context = SessionContext serverIn absRootDir messageChan reqMap
 140       initState = SessionState (IdInt 9)
 141
 142   forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 143   (result, _) <- runSession' messageChan context initState session
 144
 145   terminateProcess serverProc
 146
 147   return result
 148
 149 -- | Listens to the server output, makes sure it matches the record and
 150 -- signals any semaphores
 151 listenServer :: Handle -> Session ()
 152 listenServer serverOut = do
 153   msgBytes <- liftIO $ getNextMessage serverOut
 154
 155   context <- ask
 156   reqMap <- liftIO $ readMVar $ requestMap context
 157
 158   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 159
 160   listenServer serverOut
 161
 162 -- | Sends a request to the server.
 163 --
 164 -- @
 165 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 166 --             TextDocumentDocumentSymbol
 167 --             (DocumentSymbolParams docId)
 168 -- @
 169 sendRequest
 170   :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
 171   => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 172   -> ClientMethod -- ^ The request method.
 173   -> params -- ^ The request parameters.
 174   -> Session LspId -- ^ The id of the request that was sent.
 175 sendRequest _ method params = do
 176   id <- curReqId <$> get
 177   modify $ \c -> c { curReqId = nextId id }
 178
 179   let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
 180
 181   sendRequest' 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 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 189 sendRequest' req = do
 190   -- Update the request map
 191   reqMap <- requestMap <$> ask
 192   liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
 193
 194   sendMessage req
 195
 196 -- | Sends a notification to the server.
 197 sendNotification :: ToJSON a
 198                  => ClientMethod -- ^ The notification method.
 199                  -> a -- ^ The notification parameters.
 200                  -> Session ()
 201 sendNotification method params =
 202   let notif = NotificationMessage "2.0" method params
 203     in sendNotification' notif
 204
 205 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 206 sendNotification' = sendMessage
 207
 208 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 209 sendResponse = sendMessage
 210
 211 sendMessage :: ToJSON a => a -> Session ()
 212 sendMessage msg = do
 213   h <- serverIn <$> ask
 214   liftIO $ B.hPut h $ addHeader (encode msg)
 215
 216 -- | Reads in a text document as the first version.
 217 getDocItem :: FilePath -- ^ The path to the text document to read in.
 218            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 219            -> Session TextDocumentItem
 220 getDocItem file languageId = do
 221   context <- ask
 222   let fp = rootDir context </> file
 223   contents <- liftIO $ T.readFile fp
 224   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 225
 226 -- | Gets the Uri for the file corrected to the session directory.
 227 getDocUri :: FilePath -> Session Uri
 228 getDocUri file = do
 229   context <- ask
 230   let fp = rootDir context </> file
 231   return $ filePathToUri fp