X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=4d75d1defa541f07993874da444ed8d4cf08d0ff;hp=a64e7ad1baa86057f1e841ba5f939dc38597b9c6;hb=f0a961503e19c2d281c3d6319df1096f5bf6cfcf;hpb=9b771257fb775abdcca8e6b71e2d3d0ec4309670 diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a64e7ad..4d75d1d 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} module Language.Haskell.LSP.Test.Session ( Session , SessionConfig(..) + , defaultConfig , SessionMessage(..) , SessionContext(..) , SessionState(..) @@ -13,11 +16,14 @@ module Language.Haskell.LSP.Test.Session , get , put , modify + , modifyM , ask , asks , sendMessage , updateState , withTimeout + , logMsg + , LogMsgType(..) ) where @@ -28,12 +34,16 @@ 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) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson +import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default @@ -47,37 +57,49 @@ import Data.Maybe import Data.Function import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.Types hiding (error) +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 --- @ +-- 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'. + type Session = ParserStateReader FromServerMessage SessionState SessionContext IO +#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. Default is yes to everything. - , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60. - , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False + { 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. } +-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. +defaultConfig :: SessionConfig +defaultConfig = SessionConfig 60 False False True Nothing + instance Default SessionConfig where - def = SessionConfig def 60 False + def = defaultConfig data SessionMessage = ServerMessage FromServerMessage | TimeoutMessage Int @@ -91,6 +113,7 @@ data SessionContext = SessionContext , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities } class Monad m => HasReader r m where @@ -108,7 +131,7 @@ data SessionState = SessionState { curReqId :: LspId , vfs :: VFS - , curDiagnostics :: Map.Map Uri [Diagnostic] + , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] , curTimeoutId :: Int , overridingTimeout :: Bool -- ^ The last received message from the server. @@ -124,6 +147,9 @@ class Monad m => HasState s m where modify :: (s -> s) -> m () modify f = get >>= put . f + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put + instance Monad m => HasState s (ParserStateReader a s r m) where get = lift State.get put = lift . State.put @@ -136,16 +162,14 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state session = - -- source <- sourceList <$> getChanContents (messageChan context) - runReaderT (runStateT conduit state) context +runSession context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) handler (Unexpected "ConduitParser.empty") = do lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName - liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) handler e = throw e @@ -154,41 +178,53 @@ runSession context state session = yield msg chanSource - 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) $ throw TimeoutException + TimeoutMessage tId -> when (curId == tId) $ 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 + -> 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 initRsp <- newEmptyMVar - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config - initState = SessionState (IdInt 0) mempty mempty 0 False Nothing + mainThreadId <- myThreadId - threadId <- forkIO $ void $ serverHandler serverOut context - (result, _) <- runSession context initState session + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps + initState = SessionState (IdInt 0) mempty mempty 0 False Nothing + runSession' = runSession context initState - killThread threadId + errorHandler = throwTo mainThreadId :: SessionException -> IO() + serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler + server = (Just serverIn, Just serverOut, Nothing, serverProc) + serverFinalizer tid = finally (timeout (messageTimeout config * 1000000) + (runSession' exitServer)) + (cleanupRunningProcess server >> killThread tid) + (result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -201,13 +237,11 @@ updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify (\s -> - let newDiags = Map.insert doc diags (curDiagnostics s) + let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags }) updateState (ReqApplyWorkspaceEdit r) = do - oldVFS <- vfs <$> get - allChangeParams <- case r ^. params . edit . documentChanges of Just (List cs) -> do mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs @@ -218,10 +252,11 @@ updateState (ReqApplyWorkspaceEdit r) = do return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) Nothing -> error "No changes!" - newVFS <- liftIO $ changeFromServerVFS oldVFS r - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } - let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams + let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session @@ -235,8 +270,8 @@ updateState (ReqApplyWorkspaceEdit r) = do forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s - update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t - newVFS = Map.adjust update uri oldVFS + update (VirtualFile oldV t mf) = VirtualFile (fromMaybe oldV v) t mf + newVFS = Map.adjust update (toNormalizedUri uri) oldVFS in s { vfs = newVFS } where checkIfNeedsOpened uri = do @@ -244,16 +279,16 @@ updateState (ReqApplyWorkspaceEdit r) = do ctx <- ask -- if its not open, open it - unless (uri `Map.member` oldVFS) $ do + unless (toNormalizedUri uri `Map.member` 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) - oldVFS <- vfs <$> get - newVFS <- liftIO $ openVFS oldVFS msg - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ 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 @@ -273,16 +308,10 @@ updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () sendMessage msg = do h <- serverIn <$> ask - let encoded = encode msg - liftIO $ do + logMsg LogClient msg + liftIO $ B.hPut h (addHeader $ encode msg) - setSGR [SetColor Foreground Vivid Cyan] - putStrLn $ "--> " ++ B.unpack encoded - setSGR [Reset] - - B.hPut h (addHeader encoded) - --- | Execute a block f that will throw a 'TimeoutException' +-- | 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 @@ -298,3 +327,27 @@ withTimeout duration f = do 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 +