src/Language/Haskell/LSP/Test/Session.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5
   6 module Language.Haskell.LSP.Test.Session
   7   ( Session
   8   , SessionConfig(..)
   9   , SessionMessage(..)
  10   , SessionContext(..)
  11   , SessionState(..)
  12   , runSessionWithHandles
  13   , get
  14   , put
  15   , modify
  16   , ask
  17   , asks
  18   , sendMessage
  19   , updateState
  20   , withTimeout
  21   )
  22
  23 where
  24
  25 import Control.Concurrent hiding (yield)
  26 import Control.Exception
  27 import Control.Lens hiding (List)
  28 import Control.Monad
  29 import Control.Monad.IO.Class
  30 import Control.Monad.Except
  31 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  32 import qualified Control.Monad.Trans.Reader as Reader (ask)
  33 import Control.Monad.Trans.State (StateT, runStateT)
  34 import qualified Control.Monad.Trans.State as State (get, put)
  35 import qualified Data.ByteString.Lazy.Char8 as B
  36 import Data.Aeson
  37 import Data.Conduit as Conduit
  38 import Data.Conduit.Parser as Parser
  39 import Data.Default
  40 import Data.Foldable
  41 import Data.List
  42 import qualified Data.Map as Map
  43 import qualified Data.Text as T
  44 import qualified Data.Text.IO as T
  45 import qualified Data.HashMap.Strict as HashMap
  46 import Data.Maybe
  47 import Language.Haskell.LSP.Messages
  48 import Language.Haskell.LSP.TH.ClientCapabilities
  49 import Language.Haskell.LSP.Types hiding (error)
  50 import Language.Haskell.LSP.VFS
  51 import Language.Haskell.LSP.Test.Decoding
  52 import Language.Haskell.LSP.Test.Exceptions
  53 import System.Console.ANSI
  54 import System.Directory
  55 import System.IO
  56
  57 -- | A session representing one instance of launching and connecting to a server.
  58 --
  59 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  60 -- 'sendRequest' and 'sendNotification'.
  61 --
  62 -- @
  63 -- runSession \"path\/to\/root\/dir\" $ do
  64 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  65 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  66 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  67 -- @
  68 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  69
  70 -- | Stuff you can configure for a 'Session'.
  71 data SessionConfig = SessionConfig
  72   {
  73     capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
  74   , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60.
  75   , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
  76   }
  77
  78 instance Default SessionConfig where
  79   def = SessionConfig def 60 False
  80
  81 data SessionMessage = ServerMessage FromServerMessage
  82                     | TimeoutMessage Int
  83   deriving Show
  84
  85 data SessionContext = SessionContext
  86   {
  87     serverIn :: Handle
  88   , rootDir :: FilePath
  89   , messageChan :: Chan SessionMessage
  90   , requestMap :: MVar RequestMap
  91   , initRsp :: MVar InitializeResponse
  92   , config :: SessionConfig
  93   }
  94
  95 class Monad m => HasReader r m where
  96   ask :: m r
  97   asks :: (r -> b) -> m b
  98   asks f = f <$> ask
  99
 100 instance Monad m => HasReader r (ParserStateReader a s r m) where
 101   ask = lift $ lift Reader.ask
 102
 103 instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
 104   ask = lift $ lift Reader.ask
 105
 106 data SessionState = SessionState
 107   {
 108     curReqId :: LspId
 109   , vfs :: VFS
 110   , curDiagnostics :: Map.Map Uri [Diagnostic]
 111   , curTimeoutId :: Int
 112   , overridingTimeout :: Bool
 113   -- ^ The last received message from the server.
 114   -- Used for providing exception information
 115   , lastReceivedMessage :: Maybe FromServerMessage
 116   }
 117
 118 class Monad m => HasState s m where
 119   get :: m s
 120
 121   put :: s -> m ()
 122
 123   modify :: (s -> s) -> m ()
 124   modify f = get >>= put . f
 125
 126 instance Monad m => HasState s (ParserStateReader a s r m) where
 127   get = lift State.get
 128   put = lift . State.put
 129
 130 instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
 131  where
 132   get = lift State.get
 133   put = lift . State.put
 134
 135 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
 136
 137 runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 138 runSession context state session =
 139     -- source <- sourceList <$> getChanContents (messageChan context)
 140     runReaderT (runStateT conduit state) context
 141   where
 142     conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
 143
 144     handler (Unexpected "ConduitParser.empty") = do
 145       lastMsg <- fromJust . lastReceivedMessage <$> get
 146       name <- getParserName
 147       liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 148
 149     handler e = throw e
 150
 151     chanSource = do
 152       msg <- liftIO $ readChan (messageChan context)
 153       yield msg
 154       chanSource
 155
 156
 157     watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 158     watchdog = Conduit.awaitForever $ \msg -> do
 159       curId <- curTimeoutId <$> get
 160       case msg of
 161         ServerMessage sMsg -> yield sMsg
 162         TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException
 163
 164 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 165 -- It also does not automatically send initialize and exit messages.
 166 runSessionWithHandles :: Handle -- ^ Server in
 167                       -> Handle -- ^ Server out
 168                       -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
 169                       -> SessionConfig
 170                       -> FilePath
 171                       -> Session a
 172                       -> IO a
 173 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 174   absRootDir <- canonicalizePath rootDir
 175
 176   hSetBuffering serverIn  NoBuffering
 177   hSetBuffering serverOut NoBuffering
 178
 179   reqMap <- newMVar newRequestMap
 180   messageChan <- newChan
 181   initRsp <- newEmptyMVar
 182
 183   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 184       initState = SessionState (IdInt 0) mempty mempty 0 False Nothing
 185
 186   threadId <- forkIO $ void $ serverHandler serverOut context
 187   (result, _) <- runSession context initState session
 188
 189   killThread threadId
 190
 191   return result
 192
 193 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 194 updateStateC = awaitForever $ \msg -> do
 195   updateState msg
 196   yield msg
 197
 198 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
 199 updateState (NotPublishDiagnostics n) = do
 200   let List diags = n ^. params . diagnostics
 201       doc = n ^. params . uri
 202   modify (\s ->
 203     let newDiags = Map.insert doc diags (curDiagnostics s)
 204       in s { curDiagnostics = newDiags })
 205
 206 updateState (ReqApplyWorkspaceEdit r) = do
 207
 208   allChangeParams <- case r ^. params . edit . documentChanges of
 209     Just (List cs) -> do
 210       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
 211       return $ map getParams cs
 212     Nothing -> case r ^. params . edit . changes of
 213       Just cs -> do
 214         mapM_ checkIfNeedsOpened (HashMap.keys cs)
 215         return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
 216       Nothing -> error "No changes!"
 217
 218   oldVFS <- vfs <$> get
 219   newVFS <- liftIO $ changeFromServerVFS oldVFS r
 220   modify (\s -> s { vfs = newVFS })
 221
 222   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
 223       mergedParams = map mergeParams groupedParams
 224
 225   -- TODO: Don't do this when replaying a session
 226   forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
 227
 228   where checkIfNeedsOpened uri = do
 229           oldVFS <- vfs <$> get
 230           ctx <- ask
 231
 232           -- if its not open, open it
 233           unless (uri `Map.member` oldVFS) $ do
 234             let fp = fromJust $ uriToFilePath uri
 235             contents <- liftIO $ T.readFile fp
 236             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 237                 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
 238             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 239
 240             oldVFS <- vfs <$> get
 241             newVFS <- liftIO $ openVFS oldVFS msg
 242             modify (\s -> s { vfs = newVFS })
 243
 244         getParams (TextDocumentEdit docId (List edits)) =
 245           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 246             in DidChangeTextDocumentParams docId (List changeEvents)
 247
 248         textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
 249
 250         textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
 251
 252         getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
 253
 254         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 255         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 256                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 257 updateState _ = return ()
 258
 259 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
 260 sendMessage msg = do
 261   h <- serverIn <$> ask
 262   let encoded = encode msg
 263   liftIO $ do
 264
 265     setSGR [SetColor Foreground Vivid Cyan]
 266     putStrLn $ "--> " ++ B.unpack encoded
 267     setSGR [Reset]
 268
 269     B.hPut h (addHeader encoded)
 270
 271 -- | Execute a block f that will throw a 'TimeoutException'
 272 -- after duration seconds. This will override the global timeout
 273 -- for waiting for messages to arrive defined in 'SessionConfig'.
 274 withTimeout :: Int -> Session a -> Session a
 275 withTimeout duration f = do
 276   chan <- asks messageChan
 277   timeoutId <- curTimeoutId <$> get
 278   modify $ \s -> s { overridingTimeout = True }
 279   liftIO $ forkIO $ do
 280     threadDelay (duration * 1000000)
 281     writeChan chan (TimeoutMessage timeoutId)
 282   res <- f
 283   modify $ \s -> s { curTimeoutId = timeoutId + 1,
 284                      overridingTimeout = False
 285                    }
 286   return res