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:
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
-> 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
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
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
-
sendNotification Initialized InitializedParams
case lspConfig config of
-- 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
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
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
#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
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
-- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'
data SessionException = Timeout
+ | NoContentLengthHeader
| UnexpectedMessage String FromServerMessage
| ReplayOutOfOrder FromServerMessage [FromServerMessage]
| UnexpectedDiagnostics
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" ++
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
-- 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
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
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
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
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.
--
-- 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
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)) ()
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 ()
projects / lsp-test.git / commitdiff