From: Luke Lau Date: Tue, 6 Aug 2019 21:46:51 +0000 (+0100) Subject: Merge pull request #44 from jneira/fix-win-tests X-Git-Tag: 0.6.1.0~2 X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=d126623dc6895d325e3d204d74e2a22d4f515587;hp=b55e218ac360e2b69d07635a7c8354e909b2bd94 Merge pull request #44 from jneira/fix-win-tests Fix non terminating tests in Windows --- diff --git a/.travis.yml b/.travis.yml index 48ba592..cb44faf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -84,8 +84,9 @@ before_install: install: - cabal v2-build script: -# until cabal v2-test supports streaming results -- cabal v2-run lsp-test:test:tests +# until cabal v2-test supports streaming results we use v2-run +# skipping for now testing the manual javascript session +- cabal v2-run lsp-test:test:tests -- --skip="manual javascript session passes a test" jobs: include: diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index e946cb7..1b2e7ba 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -94,7 +94,6 @@ import qualified Data.Text.IO as T import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap -import Data.IORef import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Types @@ -138,8 +137,6 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session -> Session a -- ^ The session to run. -> IO a runSessionWithConfig config serverExe caps rootDir session = do - -- We use this IORef to make exception non-fatal when the server is supposed to shutdown. - exitOk <- newIORef False pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir @@ -150,9 +147,8 @@ runSessionWithConfig config serverExe caps rootDir session = do caps (Just TraceOff) Nothing - withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> - runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do - + withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc -> + runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -160,7 +156,6 @@ runSessionWithConfig config serverExe caps rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams case lspConfig config of @@ -169,23 +164,14 @@ runSessionWithConfig config serverExe caps rootDir session = do -- Run the actual test result <- session - - liftIO $ atomicWriteIORef exitOk True - sendNotification Exit ExitParams - return result where - catchWhenTrue :: IORef Bool -> IO () -> IO () - catchWhenTrue exitOk a = - a `catch` (\e -> do - x <- readIORef exitOk - unless x $ throw (e :: SomeException)) - - -- | Listens to the server output, makes sure it matches the record and - -- signals any semaphores - -- Note that on Windows, we cannot kill a thread stuck in getNextMessage. - -- So we have to wait for the exit notification to kill the process first - -- and then getNextMessage will fail. + -- | Asks the server to shutdown and exit politely + exitServer :: Session () + exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams + + -- | Listens to the server output until the shutdown ack, + -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do msgBytes <- getNextMessage serverOut @@ -195,7 +181,9 @@ runSessionWithConfig config serverExe caps rootDir session = do let msg = decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) - listenServer serverOut context + case msg of + (RspShutdown _) -> return () + _ -> listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs index 9467a32..883bfc9 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -6,14 +6,30 @@ module Language.Haskell.LSP.Test.Compat where import Data.Maybe +import System.IO #if MIN_VERSION_process(1,6,3) -import System.Process hiding (getPid) +-- We have to hide cleanupProcess for process-1.6.3.0 +-- cause it is in the public api for 1.6.3.0 versions +-- shipped with ghc >= 8.6 and < 8.6.4 +import System.Process hiding (getPid, cleanupProcess, withCreateProcess) +# if MIN_VERSION_process(1,6,4) +import qualified System.Process (getPid, cleanupProcess, withCreateProcess) +# else +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) + import qualified System.Process (getPid) +import qualified Control.Exception as C +# endif #else -import System.Process -import System.Process.Internals import Control.Concurrent.MVar +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) +import System.Process hiding (withCreateProcess) +import System.Process.Internals + +import qualified Control.Exception as C #endif #ifdef mingw32_HOST_OS @@ -52,3 +68,48 @@ getProcessID p = fromIntegral . fromJust <$> getProcessID' p #endif _ -> return Nothing #endif + +cleanupProcess + :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () + +withCreateProcess + :: CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a + +#if MIN_VERSION_process(1,6,4) + +cleanupProcess = System.Process.cleanupProcess + +withCreateProcess = System.Process.withCreateProcess + +#else + +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do + -- We ignore the spurious "permission denied" error in windows: + -- see https://github.com/haskell/process/issues/110 + ignorePermDenied $ terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + + return () + where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE + ignorePermDenied = ignoreIOError PermissionDenied eACCES + +ignoreIOError :: IOErrorType -> Errno -> IO () -> IO () +ignoreIOError ioErrorType errno = + C.handle $ \e -> case e of + IOError { ioe_type = iot + , ioe_errno = Just ioe } + | iot == ioErrorType && Errno ioe == errno -> return () + _ -> C.throwIO e + +withCreateProcess c action = + C.bracket (createProcess c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + +#endif diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index 27c7770..af91928 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -32,7 +32,7 @@ getNextMessage :: Handle -> IO B.ByteString getNextMessage h = do headers <- getHeaders h case read . init <$> lookup "Content-Length" headers of - Nothing -> error "Couldn't read Content-Length header" + Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index b1e0635..dd31ea3 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as B -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' data SessionException = Timeout + | NoContentLengthHeader | UnexpectedMessage String FromServerMessage | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics @@ -24,6 +25,7 @@ instance Exception SessionException instance Show SessionException where show Timeout = "Timed out waiting to receive a message from the server." + show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index b2d54a3..ac55e9e 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -23,6 +23,7 @@ import Control.Monad import System.FilePath import System.IO import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Messages @@ -43,8 +44,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - withServer serverExe False $ \serverIn serverOut pid -> do + withServer serverExe False $ \serverIn serverOut serverProc -> do + pid <- getProcessID serverProc events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events @@ -59,12 +61,12 @@ replaySession serverExe sessionDir = do mainThread <- myThreadId sessionThread <- liftIO $ forkIO $ - runSessionWithHandles serverIn - serverOut + runSessionWithHandles serverIn serverOut serverProc (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) def fullCaps sessionDir + (return ()) -- No finalizer cleanup (sendMessages clientMsgs reqSema rspSema) takeMVar passSema killThread sessionThread diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs index 5449dfb..e66ed0a 100644 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -4,9 +4,9 @@ import Control.Concurrent.Async import Control.Monad import Language.Haskell.LSP.Test.Compat import System.IO -import System.Process +import System.Process hiding (withCreateProcess) -withServer :: String -> Bool -> (Handle -> Handle -> Int -> IO a) -> IO a +withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a withServer serverExe logStdErr f = do -- TODO Probably should just change runServer to accept -- separate command and arguments @@ -19,5 +19,4 @@ withServer serverExe logStdErr f = do hSetBinaryMode serverErr True let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn withAsync errSinkThread $ \_ -> do - pid <- getProcessID serverProc - f serverIn serverOut pid + f serverIn serverOut serverProc diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 46155f0..8e1afa8 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -60,11 +60,14 @@ 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. -- @@ -186,13 +189,15 @@ runSession context state session = runReaderT (runStateT conduit state) context -- 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 -> ClientCapabilities -> FilePath -- ^ Root directory + -> Session () -- ^ To exit the Server properly -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do +runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -210,11 +215,19 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps initState = SessionState (IdInt 0) mempty mempty 0 False Nothing - launchServerHandler = forkIO $ catch (serverHandler serverOut context) - (throwTo mainThreadId :: SessionException -> IO ()) - (result, _) <- bracket launchServerHandler killThread $ - const $ runSession context initState session - + runSession' = runSession context initState + + 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 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () diff --git a/test/Test.hs b/test/Test.hs index cdcdf5d..75e1628 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -104,7 +104,7 @@ main = hspec $ do it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do loggingNotification - liftIO $ threadDelay 10 + liftIO $ threadDelay $ 10 * 1000000 _ <- openDoc "Desktop/simple.hs" "haskell" return ()