diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.6.1.0 -- 2019-08-24 + +* Add `satisfyMaybe` (@cocreature) + ## 0.6.0.0 -- 2019-07-04 * Update to haskell-lsp-0.15.0.0 (@lorenzo) diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.6.0.0 +version: 0.6.1.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -94,7 +94,6 @@ 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 @@ -> 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 @@ 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 @@ initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams case lspConfig config of @@ -169,23 +164,14 @@ -- 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)) + -- | Asks the server to shutdown and exit politely + exitServer :: Session () + exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams - -- | 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. + -- | 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 @@ 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 --- 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 @@ -51,4 +67,49 @@ OpenHandle pid -> return $ Just pid #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 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -32,7 +32,7 @@ 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 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -12,6 +12,7 @@ -- | 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 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/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -24,7 +24,6 @@ import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser -import Data.Maybe import qualified Data.Text as T import Data.Typeable import Language.Haskell.LSP.Messages @@ -65,8 +64,14 @@ -- -- @since 0.5.2.0 satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage -satisfy pred = do +satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) +-- | Consumes and returns the result of the specified predicate if it returns `Just`. +-- +-- @since 0.6.1.0 +satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a +satisfyMaybe pred = do + skipTimeout <- overridingTimeout <$> get timeoutId <- curTimeoutId <$> get unless skipTimeout $ do @@ -83,18 +88,18 @@ modify $ \s -> s { lastReceivedMessage = Just x } - if pred x - then do + case pred x of + Just a -> do logMsg LogServer x - return x - else empty + return a + Nothing -> empty -- | Matches a message of type @a@. message :: forall a. (Typeable a, FromJSON a) => Session a message = let parser = decode . encodeMsg :: FromServerMessage -> Maybe a in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ - castMsg <$> satisfy (isJust . parser) + satisfyMaybe parser -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage @@ -112,17 +117,15 @@ responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) - x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) - return $ castMsg x + satisfyMaybe $ \msg -> do + z <- parser msg + guard (z ^. LSP.id == responseId lid) + pure z -- | Matches any type of message. anyMessage :: Session FromServerMessage anyMessage = satisfy (const True) --- | A stupid method for getting out the inner message. -castMsg :: FromJSON a => FromServerMessage -> a -castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg - -- | A version of encode that encodes FromServerMessages as if they -- weren't wrapped. encodeMsg :: FromServerMessage -> B.ByteString @@ -140,8 +143,7 @@ -- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' -- (textDocument/publishDiagnostics) notification. publishDiagnosticsNotification :: Session PublishDiagnosticsNotification -publishDiagnosticsNotification = named "Publish diagnostics notification" $ do - NotPublishDiagnostics diags <- satisfy test - return diags - where test (NotPublishDiagnostics _) = True - test _ = False +publishDiagnosticsNotification = named "Publish diagnostics notification" $ + satisfyMaybe $ \msg -> case msg of + NotPublishDiagnostics diags -> Just diags + _ -> Nothing diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens as LSP hiding (error) import Data.Aeson import Data.Default @@ -23,13 +23,14 @@ 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 import Language.Haskell.LSP.Test.Server import Language.Haskell.LSP.Test.Session --- | Replays a captured client output and +-- | Replays a captured client output and -- makes sure it matches up with an expected response. -- The session directory should have a captured session file in it -- named "session.log". @@ -43,8 +44,9 @@ -- 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 @@ 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 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ b/src/Language/Haskell/LSP/Test/Server.hs @@ -4,9 +4,9 @@ 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 @@ 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 --- 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 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 @@ -- 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 @@ 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 --- a/test/Test.hs +++ b/test/Test.hs @@ -104,7 +104,7 @@ 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 ()