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   , getMessage
  28   -- * Utilities
  29   , getDocItem
  30   , getDocUri
  31   ) where
  32
  33 import Control.Monad
  34 import Control.Monad.Trans.Class
  35 import Control.Monad.IO.Class
  36 import Control.Monad.Trans.Reader
  37 import Control.Monad.Trans.State
  38 import Control.Concurrent
  39 import qualified Data.Text as T
  40 import qualified Data.Text.IO as T
  41 import Data.Aeson
  42 import qualified Data.ByteString.Lazy.Char8 as B
  43 import Data.Default
  44 import Data.Maybe
  45 import Data.Proxy
  46 import System.Process
  47 import Language.Haskell.LSP.Types hiding (error, id)
  48 import Language.Haskell.LSP.Test.Compat
  49 import System.IO
  50 import System.Directory
  51 import System.FilePath
  52 import Language.Haskell.LSP.Test.Parsing
  53
  54 data SessionContext = SessionContext
  55   {
  56     messageSema :: MVar B.ByteString,
  57     serverIn :: Handle,
  58     rootDir :: FilePath
  59   }
  60
  61 newtype SessionState = SessionState
  62   {
  63     curReqId :: LspId
  64   }
  65
  66 -- | A session representing one instance of launching and connecting to a server.
  67 --
  68 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  69 -- 'sendRequest' and 'sendNotification'.
  70 --
  71 -- @
  72 -- runSession \"path\/to\/root\/dir\" $ do
  73 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  74 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  75 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  76 -- @
  77 --
  78 type Session = StateT SessionState (ReaderT SessionContext IO)
  79
  80 -- | Starts a new session.
  81 runSession :: FilePath -- ^ The filepath to the root directory for the session.
  82            -> Session a -- ^ The session to run.
  83            -> IO ()
  84 runSession rootDir session = do
  85   pid <- getProcessID
  86   absRootDir <- canonicalizePath rootDir
  87
  88   let initializeParams = InitializeParams (Just pid)
  89                                           (Just $ T.pack absRootDir)
  90                                           (Just $ filePathToUri absRootDir)
  91                                           Nothing
  92                                           def
  93                                           (Just TraceOff)
  94
  95   runSessionWithHandler listenServer rootDir $ do
  96
  97     -- Wrap the session around initialize and shutdown calls
  98     sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
  99     (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage
 100     liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e
 101
 102     sendNotification Initialized InitializedParams
 103
 104     -- Run the actual test
 105     session
 106
 107     sendNotification Exit ExitParams
 108
 109 runSessionWithHandler :: (Handle -> Session ())
 110                       -> FilePath
 111                       -> Session a
 112                       -> IO a
 113 runSessionWithHandler serverHandler rootDir session = do
 114   absRootDir <- canonicalizePath rootDir
 115
 116   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
 117     (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
 118     { std_in = CreatePipe, std_out = CreatePipe }
 119
 120   hSetBuffering serverIn  NoBuffering
 121   hSetBuffering serverOut NoBuffering
 122
 123   messageSema <- newEmptyMVar
 124
 125   let context = SessionContext messageSema serverIn absRootDir
 126       initState = SessionState (IdInt 9)
 127
 128   forkIO $ void $ runReaderT (runStateT (serverHandler serverOut) initState) context
 129   (result, _) <- runReaderT (runStateT session initState) context
 130
 131   terminateProcess serverProc
 132
 133   return result
 134
 135 -- | Listens to the server output, makes sure it matches the record and
 136 -- signals any semaphores
 137 listenServer :: Handle -> Session ()
 138 listenServer serverOut = do
 139   context <- lift ask
 140   msgBytes <- liftIO $ getNextMessage serverOut
 141
 142   liftIO $ case decode msgBytes :: Maybe LogMessageNotification of
 143     -- Just print log and show messages
 144     Just (NotificationMessage _ WindowLogMessage (LogMessageParams _ msg)) -> T.putStrLn msg
 145     _ -> case decode msgBytes :: Maybe ShowMessageNotification of
 146       Just (NotificationMessage _ WindowShowMessage (ShowMessageParams _ msg)) -> T.putStrLn msg
 147     -- Give everything else for getMessage to handle
 148       _ -> putMVar (messageSema context) msgBytes
 149
 150   listenServer serverOut
 151
 152 -- | Sends a request to the server.
 153 --
 154 -- @
 155 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 156 --             TextDocumentDocumentSymbol
 157 --             (DocumentSymbolParams docId)
 158 -- @
 159 sendRequest
 160   :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
 161   => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 162   -> ClientMethod -- ^ The request method.
 163   -> params -- ^ The request parameters.
 164   -> Session LspId -- ^ The id of the request that was sent.
 165 sendRequest _ method params = do
 166   id <- curReqId <$> get
 167   get >>= \c -> put c { curReqId = nextId id }
 168
 169   let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
 170
 171   sendRequest' req
 172
 173   return id
 174
 175   where nextId (IdInt i) = IdInt (i + 1)
 176         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 177
 178 sendRequest' :: (ToJSON a, ToJSON b, ToJSON c) => RequestMessage a b c -> Session ()
 179 sendRequest' = sendMessage
 180
 181 -- | Sends a notification to the server.
 182 sendNotification :: ToJSON a
 183                  => ClientMethod -- ^ The notification method.
 184                  -> a -- ^ The notification parameters.
 185                  -> Session ()
 186 sendNotification method params =
 187   let notif = NotificationMessage "2.0" method params
 188     in sendNotification' notif
 189
 190 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 191 sendNotification' = sendMessage
 192
 193 sendResponse' :: ToJSON a => ResponseMessage a -> Session ()
 194 sendResponse' = sendMessage
 195
 196 sendMessage :: ToJSON a => a -> Session ()
 197 sendMessage msg = do
 198   h <- serverIn <$> lift ask
 199   liftIO $ B.hPut h $ addHeader (encode msg)
 200
 201 -- | Reads in a message from the server.
 202 getMessage :: FromJSON a => Session a
 203 getMessage = do
 204   sema <- messageSema <$> lift ask
 205   bytes <- liftIO $ takeMVar sema
 206   return $ fromMaybe (error $ "Wrong type! Got: " ++ show bytes) (decode bytes)
 207
 208 -- | Reads in a text document as the first version.
 209 getDocItem :: FilePath -- ^ The path to the text document to read in.
 210            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 211            -> Session TextDocumentItem
 212 getDocItem file languageId = do
 213   context <- lift ask
 214   let fp = rootDir context </> file
 215   contents <- liftIO $ T.readFile fp
 216   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 217
 218 -- | Gets the Uri for the file corrected to the session directory.
 219 getDocUri :: FilePath -> Session Uri
 220 getDocUri file = do
 221   context <- lift ask
 222   let fp = rootDir context </> file
 223   return $ filePathToUri fp