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

   1 {-# LANGUAGE CPP               #-}
   2 {-# LANGUAGE GADTs             #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE FlexibleInstances #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE FlexibleContexts #-}
   8 {-# LANGUAGE RankNTypes #-}
   9
  10 module Language.Haskell.LSP.Test.Session
  11   ( Session(..)
  12   , SessionConfig(..)
  13   , defaultConfig
  14   , SessionMessage(..)
  15   , SessionContext(..)
  16   , SessionState(..)
  17   , runSession'
  18   , get
  19   , put
  20   , modify
  21   , modifyM
  22   , ask
  23   , asks
  24   , sendMessage
  25   , updateState
  26   , withTimeout
  27   , getCurTimeoutId
  28   , bumpTimeoutId
  29   , logMsg
  30   , LogMsgType(..)
  31   )
  32
  33 where
  34
  35 import Control.Applicative
  36 import Control.Concurrent hiding (yield)
  37 import Control.Exception
  38 import Control.Lens hiding (List)
  39 import Control.Monad
  40 import Control.Monad.IO.Class
  41 import Control.Monad.Except
  42 #if __GLASGOW_HASKELL__ == 806
  43 import Control.Monad.Fail
  44 #endif
  45 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  46 import qualified Control.Monad.Trans.Reader as Reader (ask)
  47 import Control.Monad.Trans.State (StateT, runStateT)
  48 import qualified Control.Monad.Trans.State as State
  49 import qualified Data.ByteString.Lazy.Char8 as B
  50 import Data.Aeson
  51 import Data.Aeson.Encode.Pretty
  52 import Data.Conduit as Conduit
  53 import Data.Conduit.Parser as Parser
  54 import Data.Default
  55 import Data.Foldable
  56 import Data.List
  57 import qualified Data.Map as Map
  58 import qualified Data.Text as T
  59 import qualified Data.Text.IO as T
  60 import qualified Data.HashMap.Strict as HashMap
  61 import Data.Maybe
  62 import Data.Function
  63 import Language.Haskell.LSP.Types.Capabilities
  64 import Language.Haskell.LSP.Types
  65 import Language.Haskell.LSP.Types.Lens
  66 import qualified Language.Haskell.LSP.Types.Lens as LSP
  67 import Language.Haskell.LSP.VFS
  68 import Language.Haskell.LSP.Test.Compat
  69 import Language.Haskell.LSP.Test.Decoding
  70 import Language.Haskell.LSP.Test.Exceptions
  71 import System.Console.ANSI
  72 import System.Directory
  73 import System.IO
  74 import System.Process (ProcessHandle())
  75 #ifndef mingw32_HOST_OS
  76 import System.Process (waitForProcess)
  77 #endif
  78 import System.Timeout
  79
  80 -- | A session representing one instance of launching and connecting to a server.
  81 --
  82 -- You can send and receive messages to the server within 'Session' via
  83 -- 'Language.Haskell.LSP.Test.message',
  84 -- 'Language.Haskell.LSP.Test.sendRequest' and
  85 -- 'Language.Haskell.LSP.Test.sendNotification'.
  86
  87 newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
  88   deriving (Functor, Applicative, Monad, MonadIO, Alternative)
  89
  90 #if __GLASGOW_HASKELL__ >= 806
  91 instance MonadFail Session where
  92   fail s = do
  93     lastMsg <- fromJust . lastReceivedMessage <$> get
  94     liftIO $ throw (UnexpectedMessage s lastMsg)
  95 #endif
  96
  97 -- | Stuff you can configure for a 'Session'.
  98 data SessionConfig = SessionConfig
  99   { messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.
 100   , logStdErr      :: Bool
 101   -- ^ Redirect the server's stderr to this stdout, defaults to False.
 102   -- Can be overriden with @LSP_TEST_LOG_STDERR@.
 103   , logMessages    :: Bool
 104   -- ^ Trace the messages sent and received to stdout, defaults to False.
 105   -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
 106   , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
 107   , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
 108   , ignoreLogNotifications :: Bool
 109   -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and
 110   -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
 111   --
 112   -- @since 0.9.0.0
 113   , initialWorkspaceFolders :: Maybe [WorkspaceFolder]
 114   -- ^ The initial workspace folders to send in the @initialize@ request.
 115   -- Defaults to Nothing.
 116   }
 117
 118 -- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
 119 defaultConfig :: SessionConfig
 120 defaultConfig = SessionConfig 60 False False True Nothing False Nothing
 121
 122 instance Default SessionConfig where
 123   def = defaultConfig
 124
 125 data SessionMessage = ServerMessage FromServerMessage
 126                     | TimeoutMessage Int
 127   deriving Show
 128
 129 data SessionContext = SessionContext
 130   {
 131     serverIn :: Handle
 132   , rootDir :: FilePath
 133   , messageChan :: Chan SessionMessage -- ^ Where all messages come through
 134   -- Keep curTimeoutId in SessionContext, as its tied to messageChan
 135   , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
 136   , requestMap :: MVar RequestMap
 137   , initRsp :: MVar InitializeResponse
 138   , config :: SessionConfig
 139   , sessionCapabilities :: ClientCapabilities
 140   }
 141
 142 class Monad m => HasReader r m where
 143   ask :: m r
 144   asks :: (r -> b) -> m b
 145   asks f = f <$> ask
 146
 147 instance HasReader SessionContext Session where
 148   ask  = Session (lift $ lift Reader.ask)
 149
 150 instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
 151   ask = lift $ lift Reader.ask
 152
 153 getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
 154 getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar
 155
 156 -- Pass this the timeoutid you *were* waiting on
 157 bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
 158 bumpTimeoutId prev = do
 159   v <- asks curTimeoutId
 160   -- when updating the curtimeoutid, account for the fact that something else
 161   -- might have bumped the timeoutid in the meantime
 162   liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1)))
 163
 164 data SessionState = SessionState
 165   {
 166     curReqId :: Int
 167   , vfs :: VFS
 168   , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
 169   , overridingTimeout :: Bool
 170   -- ^ The last received message from the server.
 171   -- Used for providing exception information
 172   , lastReceivedMessage :: Maybe FromServerMessage
 173   , curDynCaps :: Map.Map T.Text SomeRegistration
 174   -- ^ The capabilities that the server has dynamically registered with us so
 175   -- far
 176   }
 177
 178 class Monad m => HasState s m where
 179   get :: m s
 180
 181   put :: s -> m ()
 182
 183   modify :: (s -> s) -> m ()
 184   modify f = get >>= put . f
 185
 186   modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
 187   modifyM f = get >>= f >>= put
 188
 189 instance HasState SessionState Session where
 190   get = Session (lift State.get)
 191   put = Session . lift . State.put
 192
 193 instance Monad m => HasState s (StateT s m) where
 194   get = State.get
 195   put = State.put
 196
 197 instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)
 198  where
 199   get = lift get
 200   put = lift . put
 201
 202 instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)
 203  where
 204   get = lift get
 205   put = lift . put
 206
 207 runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 208 runSessionMonad context state (Session session) = runReaderT (runStateT conduit state) context
 209   where
 210     conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
 211
 212     handler (Unexpected "ConduitParser.empty") = do
 213       lastMsg <- fromJust . lastReceivedMessage <$> get
 214       name <- getParserName
 215       liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)
 216
 217     handler e = throw e
 218
 219     chanSource = do
 220       msg <- liftIO $ readChan (messageChan context)
 221       unless (ignoreLogNotifications (config context) && isLogNotification msg) $
 222         yield msg
 223       chanSource
 224
 225     isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True
 226     isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True
 227     isLogNotification _ = False
 228
 229     watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 230     watchdog = Conduit.awaitForever $ \msg -> do
 231       curId <- getCurTimeoutId
 232       case msg of
 233         ServerMessage sMsg -> yield sMsg
 234         TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout
 235
 236 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 237 -- It also does not automatically send initialize and exit messages.
 238 runSession' :: Handle -- ^ Server in
 239             -> Handle -- ^ Server out
 240             -> Maybe ProcessHandle -- ^ Server process
 241             -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
 242             -> SessionConfig
 243             -> ClientCapabilities
 244             -> FilePath -- ^ Root directory
 245             -> Session () -- ^ To exit the Server properly
 246             -> Session a
 247             -> IO a
 248 runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do
 249   absRootDir <- canonicalizePath rootDir
 250
 251   hSetBuffering serverIn  NoBuffering
 252   hSetBuffering serverOut NoBuffering
 253   -- This is required to make sure that we don’t get any
 254   -- newline conversion or weird encoding issues.
 255   hSetBinaryMode serverIn True
 256   hSetBinaryMode serverOut True
 257
 258   reqMap <- newMVar newRequestMap
 259   messageChan <- newChan
 260   timeoutIdVar <- newMVar 0
 261   initRsp <- newEmptyMVar
 262
 263   mainThreadId <- myThreadId
 264
 265   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
 266       initState vfs = SessionState 0 vfs mempty False Nothing mempty
 267       runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
 268
 269       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
 270       serverListenerLauncher =
 271         forkIO $ catch (serverHandler serverOut context) errorHandler
 272       msgTimeoutMs = messageTimeout config * 10^6
 273       serverAndListenerFinalizer tid = do
 274         let cleanup
 275               | Just sp <- mServerProc = do
 276                   -- Give the server some time to exit cleanly
 277                   timeout msgTimeoutMs (waitForProcess sp)
 278                   cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)
 279               | otherwise = pure ()
 280         finally (timeout msgTimeoutMs (runSession' exitServer))
 281                 -- Make sure to kill the listener first, before closing
 282                 -- handles etc via cleanupProcess
 283                 (killThread tid >> cleanup)
 284
 285   (result, _) <- bracket serverListenerLauncher
 286                          serverAndListenerFinalizer
 287                          (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)
 288   return result
 289
 290 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
 291 updateStateC = awaitForever $ \msg -> do
 292   updateState msg
 293   yield msg
 294
 295 updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
 296             => FromServerMessage -> m ()
 297
 298 -- Keep track of dynamic capability registration
 299 updateState (FromServerMess SClientRegisterCapability req) = do
 300   let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations
 301   modify $ \s ->
 302     s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
 303
 304 updateState (FromServerMess SClientUnregisterCapability req) = do
 305   let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations
 306   modify $ \s ->
 307     let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
 308     in s { curDynCaps = newCurDynCaps }
 309
 310 updateState (FromServerMess STextDocumentPublishDiagnostics n) = do
 311   let List diags = n ^. params . diagnostics
 312       doc = n ^. params . uri
 313   modify $ \s ->
 314     let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
 315       in s { curDiagnostics = newDiags }
 316
 317 updateState (FromServerMess SWorkspaceApplyEdit r) = do
 318
 319   -- First, prefer the versioned documentChanges field
 320   allChangeParams <- case r ^. params . edit . documentChanges of
 321     Just (List cs) -> do
 322       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
 323       return $ map getParams cs
 324     -- Then fall back to the changes field
 325     Nothing -> case r ^. params . edit . changes of
 326       Just cs -> do
 327         mapM_ checkIfNeedsOpened (HashMap.keys cs)
 328         concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs)
 329       Nothing ->
 330         error "WorkspaceEdit contains neither documentChanges nor changes!"
 331
 332   modifyM $ \s -> do
 333     newVFS <- liftIO $ changeFromServerVFS (vfs s) r
 334     return $ s { vfs = newVFS }
 335
 336   let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams
 337       mergedParams = map mergeParams groupedParams
 338
 339   -- TODO: Don't do this when replaying a session
 340   forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange)
 341
 342   -- Update VFS to new document versions
 343   let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
 344       latestVersions = map ((^. textDocument) . last) sortedVersions
 345       bumpedVersions = map (version . _Just +~ 1) latestVersions
 346
 347   forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->
 348     modify $ \s ->
 349       let oldVFS = vfs s
 350           update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t
 351           newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS
 352       in s { vfs = newVFS }
 353
 354   where checkIfNeedsOpened uri = do
 355           oldVFS <- vfs <$> get
 356           ctx <- ask
 357
 358           -- if its not open, open it
 359           unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do
 360             let fp = fromJust $ uriToFilePath uri
 361             contents <- liftIO $ T.readFile fp
 362             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 363                 msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)
 364             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 365
 366             modifyM $ \s -> do
 367               let (newVFS,_) = openVFS (vfs s) msg
 368               return $ s { vfs = newVFS }
 369
 370         getParams (TextDocumentEdit docId (List edits)) =
 371           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 372             in DidChangeTextDocumentParams docId (List changeEvents)
 373
 374         -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
 375         -- where n is the current version
 376         textDocumentVersions uri = do
 377           m <- vfsMap . vfs <$> get
 378           let curVer = fromMaybe 0 $
 379                 _lsp_version <$> m Map.!? (toNormalizedUri uri)
 380           pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]
 381
 382         textDocumentEdits uri edits = do
 383           vers <- textDocumentVersions uri
 384           pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits
 385
 386         getChangeParams uri (List edits) =
 387           map <$> pure getParams <*> textDocumentEdits uri (reverse edits)
 388
 389         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 390         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 391                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 392 updateState _ = return ()
 393
 394 sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
 395 sendMessage msg = do
 396   h <- serverIn <$> ask
 397   logMsg LogClient msg
 398   liftIO $ B.hPut h (addHeader $ encode msg)
 399
 400 -- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
 401 -- after duration seconds. This will override the global timeout
 402 -- for waiting for messages to arrive defined in 'SessionConfig'.
 403 withTimeout :: Int -> Session a -> Session a
 404 withTimeout duration f = do
 405   chan <- asks messageChan
 406   timeoutId <- getCurTimeoutId
 407   modify $ \s -> s { overridingTimeout = True }
 408   liftIO $ forkIO $ do
 409     threadDelay (duration * 1000000)
 410     writeChan chan (TimeoutMessage timeoutId)
 411   res <- f
 412   bumpTimeoutId timeoutId
 413   modify $ \s -> s { overridingTimeout = False }
 414   return res
 415
 416 data LogMsgType = LogServer | LogClient
 417   deriving Eq
 418
 419 -- | Logs the message if the config specified it
 420 logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
 421        => LogMsgType -> a -> m ()
 422 logMsg t msg = do
 423   shouldLog <- asks $ logMessages . config
 424   shouldColor <- asks $ logColor . config
 425   liftIO $ when shouldLog $ do
 426     when shouldColor $ setSGR [SetColor Foreground Dull color]
 427     putStrLn $ arrow ++ showPretty msg
 428     when shouldColor $ setSGR [Reset]
 429
 430   where arrow
 431           | t == LogServer  = "<-- "
 432           | otherwise       = "--> "
 433         color
 434           | t == LogServer  = Magenta
 435           | otherwise       = Cyan
 436
 437         showPretty = B.unpack . encodePretty