X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=3426bcce47c66e105ddb235b13d308a92dcafe45;hp=d12ed003a2d67e212156c9cbe5810c2ccc17055f;hb=20750dca8684bcb05a7c91e8654257ad36e57ebe;hpb=bd6901688e6c9d8332fea161260d32666885f9ed diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index d12ed00..3426bcc 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,199 +1,373 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} module Language.Haskell.LSP.Test.Session - ( Session + ( Session(..) , SessionConfig(..) + , defaultConfig + , SessionMessage(..) , SessionContext(..) , SessionState(..) - , MonadSessionConfig(..) , runSessionWithHandles , get , put , modify - , ask) + , modifyM + , ask + , asks + , sendMessage + , updateState + , withTimeout + , logMsg + , LogMsgType(..) + ) where +import Control.Applicative import Control.Concurrent hiding (yield) import Control.Exception import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except +#if __GLASGOW_HASKELL__ == 806 +import Control.Monad.Fail +#endif import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT) -import qualified Control.Monad.Trans.State as State (get, put, modify) +import qualified Control.Monad.Trans.State as State import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson -import Data.Conduit hiding (await) -import Data.Conduit.Parser +import Data.Aeson.Encode.Pretty +import Data.Conduit as Conduit +import Data.Conduit.Parser as Parser import Data.Default import Data.Foldable import Data.List +import qualified Data.Map as Map import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import Data.Function import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.TH.ClientCapabilities +import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions +import System.Console.ANSI import System.Directory import System.IO +import System.Process (ProcessHandle()) +import System.Timeout -- | A session representing one instance of launching and connecting to a server. -- --- You can send and receive messages to the server within 'Session' via 'getMessage', --- 'sendRequest' and 'sendNotification'. --- --- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification --- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO +-- You can send and receive messages to the server within 'Session' via +-- 'Language.Haskell.LSP.Test.message', +-- 'Language.Haskell.LSP.Test.sendRequest' and +-- 'Language.Haskell.LSP.Test.sendNotification'. + +newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, Alternative) + +#if __GLASGOW_HASKELL__ >= 806 +instance MonadFail Session where + fail s = do + lastMsg <- fromJust . lastReceivedMessage <$> get + liftIO $ throw (UnexpectedMessage s lastMsg) +#endif -- | Stuff you can configure for a 'Session'. data SessionConfig = SessionConfig - { - capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise. - timeout :: Int -- ^ Maximum time to wait for a request in seconds. + { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60. + , logStdErr :: Bool -- ^ Redirect the server's stderr to this stdout, defaults to False. + , logMessages :: Bool -- ^ Trace the messages sent and received to stdout, defaults to False. + , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. + , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing. + -- ^ Whether or not to ignore 'ShowMessageNotification' and 'LogMessageNotification', defaults to False. + -- @since 0.9.0.0 + , ignoreLogNotifications :: Bool } -instance Default SessionConfig where - def = SessionConfig def 60 +-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. +defaultConfig :: SessionConfig +defaultConfig = SessionConfig 60 False False True Nothing False -class Monad m => MonadSessionConfig m where - sessionConfig :: m SessionConfig +instance Default SessionConfig where + def = defaultConfig -instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where - sessionConfig = config <$> lift Reader.ask +data SessionMessage = ServerMessage FromServerMessage + | TimeoutMessage Int + deriving Show data SessionContext = SessionContext { serverIn :: Handle , rootDir :: FilePath - , messageChan :: Chan FromServerMessage + , messageChan :: Chan SessionMessage , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities } +class Monad m => HasReader r m where + ask :: m r + asks :: (r -> b) -> m b + asks f = f <$> ask + +instance HasReader SessionContext Session where + ask = Session (lift $ lift Reader.ask) + +instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where + ask = lift $ lift Reader.ask + data SessionState = SessionState { curReqId :: LspId , vfs :: VFS + , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] + , curTimeoutId :: Int + , overridingTimeout :: Bool + -- ^ The last received message from the server. + -- Used for providing exception information + , lastReceivedMessage :: Maybe FromServerMessage } -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) +class Monad m => HasState s m where + get :: m s -type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) + put :: s -> m () -runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context - where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler) - handler e@(Unexpected "ConduitParser.empty") = do + modify :: (s -> s) -> m () + modify f = get >>= put . f - -- Horrible way to get last item in conduit: - -- Add a fake message so we can tell when to stop - liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) - x <- peek - case x of - Just x -> do - lastMsg <- skipToEnd x - name <- getParserName - liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) - Nothing -> throw e - - handler e = throw e + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put - skipToEnd x = do - y <- peek - case y of - Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x - Just _ -> await >>= skipToEnd - Nothing -> return x +instance HasState SessionState Session where + get = Session (lift State.get) + put = Session . lift . State.put -get :: Monad m => ParserStateReader a s r m s +instance Monad m => HasState s (ConduitM a b (StateT s m)) + where get = lift State.get + put = lift . State.put -put :: Monad m => s -> ParserStateReader a s r m () +instance Monad m => HasState s (ConduitParser a (StateT s m)) + where + get = lift State.get put = lift . State.put -modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . State.modify +runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession context state (Session session) = runReaderT (runStateT conduit state) context + where + conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) -ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Reader.ask + handler (Unexpected "ConduitParser.empty") = do + lastMsg <- fromJust . lastReceivedMessage <$> get + name <- getParserName + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) + + handler e = throw e + + chanSource = do + msg <- liftIO $ readChan (messageChan context) + unless (ignoreLogNotifications (config context) && isLogNotification msg) $ + yield msg + chanSource + + isLogNotification (ServerMessage (NotShowMessage _)) = True + isLogNotification (ServerMessage (NotLogMessage _)) = True + isLogNotification _ = False + + watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog = Conduit.awaitForever $ \msg -> do + curId <- curTimeoutId <$> get + case msg of + ServerMessage sMsg -> yield sMsg + TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out - -> (Handle -> Session ()) -- ^ Server listener + -> ProcessHandle -- ^ Server process + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig - -> FilePath + -> ClientCapabilities + -> FilePath -- ^ Root directory + -> Session () -- ^ To exit the Server properly -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do +runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering hSetBuffering serverOut NoBuffering + -- This is required to make sure that we don’t get any + -- newline conversion or weird encoding issues. + hSetBinaryMode serverIn True + hSetBinaryMode serverOut True reqMap <- newMVar newRequestMap messageChan <- newChan - meaninglessChan <- newChan initRsp <- newEmptyMVar - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config - initState = SessionState (IdInt 0) mempty + mainThreadId <- myThreadId - threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) - (result, _) <- runSession messageChan processor context initState session + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps + initState vfs = SessionState (IdInt 0) vfs + mempty 0 False Nothing + runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses - killThread threadId + errorHandler = throwTo mainThreadId :: SessionException -> IO() + serverListenerLauncher = + forkIO $ catch (serverHandler serverOut context) errorHandler + server = (Just serverIn, Just serverOut, Nothing, serverProc) + serverAndListenerFinalizer tid = + finally (timeout (messageTimeout config * 1000000) + (runSession' exitServer)) + (cleanupProcess server >> killThread tid) + (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer + (const $ runSession' session) return result - where processor :: SessionProcessor () - processor = awaitForever $ \msg -> do - processTextChanges msg +updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC = awaitForever $ \msg -> do + updateState msg yield msg - -processTextChanges :: FromServerMessage -> SessionProcessor () -processTextChanges (ReqApplyWorkspaceEdit r) = do - List changeParams <- case r ^. params . edit . documentChanges of - Just cs -> mapM applyTextDocumentEdit cs +updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) + => FromServerMessage -> m () +updateState (NotPublishDiagnostics n) = do + let List diags = n ^. params . diagnostics + doc = n ^. params . uri + modify (\s -> + let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) + in s { curDiagnostics = newDiags }) + +updateState (ReqApplyWorkspaceEdit r) = do + + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs + return $ map getParams cs Nothing -> case r ^. params . edit . changes of - Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs)) - Nothing -> return (List []) + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> error "No changes!" - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } + + let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams $ \p -> do - h <- serverIn <$> lift (lift Reader.ask) - let msg = NotificationMessage "2.0" TextDocumentDidChange p - liftIO $ B.hPut h $ addHeader (encode msg) - - where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do - oldVFS <- vfs <$> lift State.get + forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + + -- Update VFS to new document versions + let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams + latestVersions = map ((^. textDocument) . last) sortedVersions + bumpedVersions = map (version . _Just +~ 1) latestVersions + + forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + modify $ \s -> + let oldVFS = vfs s + update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t + newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS + in s { vfs = newVFS } + + where checkIfNeedsOpened uri = do + oldVFS <- vfs <$> get + ctx <- ask + + -- if its not open, open it + unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do + let fp = fromJust $ uriToFilePath uri + contents <- liftIO $ T.readFile fp + let item = TextDocumentItem (filePathToUri fp) "" 0 contents + msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) + liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) + + modifyM $ \s -> do + let (newVFS,_) = openVFS (vfs s) msg + return $ s { vfs = newVFS } + + getParams (TextDocumentEdit docId (List edits)) = let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits - params = DidChangeTextDocumentParams docId (List changeEvents) - newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params) - lift $ State.modify (\s -> s { vfs = newVFS }) - return params + in DidChangeTextDocumentParams docId (List changeEvents) - applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits) + textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..] + + textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits + + getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits)) mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) in DidChangeTextDocumentParams (head params ^. textDocument) (List events) -processTextChanges _ = return () +updateState _ = return () + +sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () +sendMessage msg = do + h <- serverIn <$> ask + logMsg LogClient msg + liftIO $ B.hPut h (addHeader $ encode msg) + +-- | Execute a block f that will throw a 'Timeout' exception +-- after duration seconds. This will override the global timeout +-- for waiting for messages to arrive defined in 'SessionConfig'. +withTimeout :: Int -> Session a -> Session a +withTimeout duration f = do + chan <- asks messageChan + timeoutId <- curTimeoutId <$> get + modify $ \s -> s { overridingTimeout = True } + liftIO $ forkIO $ do + threadDelay (duration * 1000000) + writeChan chan (TimeoutMessage timeoutId) + res <- f + modify $ \s -> s { curTimeoutId = timeoutId + 1, + overridingTimeout = False + } + return res + +data LogMsgType = LogServer | LogClient + deriving Eq + +-- | Logs the message if the config specified it +logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m) + => LogMsgType -> a -> m () +logMsg t msg = do + shouldLog <- asks $ logMessages . config + shouldColor <- asks $ logColor . config + liftIO $ when shouldLog $ do + when shouldColor $ setSGR [SetColor Foreground Dull color] + putStrLn $ arrow ++ showPretty msg + when shouldColor $ setSGR [Reset] + + where arrow + | t == LogServer = "<-- " + | otherwise = "--> " + color + | t == LogServer = Magenta + | otherwise = Cyan + + showPretty = B.unpack . encodePretty + +