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