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