ide-backend 0.10.0 → 0.10.0.1
raw patch · 13 files changed
+149/−125 lines, 13 filesdep +networkdep +unix-compatdep ~aesondep ~asyncdep ~unix
Dependencies added: network, unix-compat
Dependency ranges changed: aeson, async, unix
Files
- IdeSession/Config.hs +9/−4
- IdeSession/ExeCabalServer.hs +3/−2
- IdeSession/GHC/Client.hs +20/−11
- IdeSession/RPC/Client.hs +22/−44
- IdeSession/Update.hs +14/−8
- IdeSession/Update/ExecuteSessionUpdate.hs +1/−1
- TestSuite/TestSuite/Session.hs +5/−2
- TestSuite/TestSuite/State.hs +4/−2
- TestSuite/TestSuite/Tests/Integration.hs +2/−1
- TestSuite/TestSuite/Tests/Performance.hs +12/−12
- ide-backend.cabal +29/−11
- test/TestTools.hs +7/−3
- test/rpc-server.hs +21/−24
IdeSession/Config.hs view
@@ -69,17 +69,22 @@ , configIdeBackendExeCabal :: (ProgramSearchPath,FilePath) } --- Get the default local session configuration, pulling the following+-- | Get the default local session configuration, pulling the following -- information from the environment: ----- * OS temporary directory (used for session.*) files+-- * OS temporary directory (used for session.* files) ----- * Current working directory - assumed to be the project root.--- Instead of running+-- * Current working directory - assumed to be the project root. Instead+-- of sending files in updates, they are read from the filesystem. -- -- * GHC package database. Like GHC, it takes the GHC_PACKAGE_PATH, -- and uses this list of package databases. This allows ide-backend -- to do the 'right thing' when used with tools like stack.+--+-- NOTE: In order for it to pull GHC_PACKAGE_PATH from the environment,+-- this must be used before any ide-backend session is initialized. This+-- is because the environment variable gets unset due to+-- https://github.com/haskell/cabal/issues/1944 sessionConfigFromEnv :: IO SessionConfig sessionConfigFromEnv = do tmpDir <- getTemporaryDirectory
IdeSession/ExeCabalServer.hs view
@@ -6,8 +6,8 @@ import Control.Concurrent.Async (async, wait) import System.Exit (ExitCode)+import System.IO (IOMode(..)) import System.IO.Error (isEOFError)-import System.Posix.IO.ByteString import qualified Control.Exception as Ex import qualified Data.ByteString as BSS import qualified Data.Text.Encoding as E@@ -17,6 +17,7 @@ import IdeSession.RPC.Server import IdeSession.Types.Progress import IdeSession.Util+import IdeSession.Util.PortableIO -- | Handle RPC requests by calling Cabal functions, keeping track -- of progress and passing the results.@@ -40,7 +41,7 @@ -- Backup stdout, then replace stdout with the pipe's write end (exitCode, stdoutThread) <- swizzleStdout stdOutputWr $ do -- Convert the read end to a handle- stdOutputRdHandle <- fdToHandle stdOutputRd+ stdOutputRdHandle <- fdToHandle stdOutputRd ReadMode IO.hSetBuffering stdOutputRdHandle IO.LineBuffering let stdoutLog = case req of
IdeSession/GHC/Client.hs view
@@ -35,7 +35,6 @@ import Data.Binary (Binary) import System.Directory (removeFile) import System.Exit (ExitCode)-import System.Posix (ProcessID, sigKILL, signalProcess) import qualified Control.Exception as Ex import qualified Data.ByteString.Char8 as BSS import qualified Data.ByteString.Lazy.Char8 as BSL@@ -48,10 +47,13 @@ import IdeSession.Types.Progress import IdeSession.Util import IdeSession.Util.BlockingOps+import IdeSession.Util.PortableProcess import qualified IdeSession.Types.Public as Public import Distribution.Simple (PackageDB(..), PackageDBStack) +import IdeSession.RPC.Sockets+ {------------------------------------------------------------------------------ Starting and stopping the server ------------------------------------------------------------------------------}@@ -197,9 +199,7 @@ GhcCompileProgress pcounter -> do updateStatus (Public.UpdateStatusProgress pcounter) go- GhcCompileDone result -> do- updateStatus Public.UpdateStatusDone- return result+ GhcCompileDone result -> return result go @@ -240,13 +240,22 @@ -- TODO: This is of course a tad dangerous, because if for whatever reason -- the communication with the main server stalls we cannot interrupt it. -- Perhaps we should introduce a separate timeout for that?- (pid, stdin, stdout, errorLog) <- Ex.uninterruptibleMask_ $ ghcRpc server (ReqRun cmd)-- -- Unmask exceptions only once we've installed an exception handler to- -- cleanup the process again- interruptible (aux pid stdin stdout errorLog) `Ex.onException` signalProcess sigKILL pid+ rpcRes <- Ex.uninterruptibleMask_ $ ghcRpc server (ReqRun cmd)+ case rpcRes of+ -- TODO maybe returnging a dummy RunActions is better than throwing an exception?+ -- ReqRunUnsupported msg -> return RunActions {+ -- runWait = fmap Right $ translateResult $ Just $ RunGhcException msg+ -- , interrupt = return ()+ -- , supplyStdin = const $ return ()+ -- , forceCancel = return ()+ -- }+ ReqRunUnsupported msg -> Ex.throwIO $ UnsupportedOnNonUnix msg+ ReqRunConversation pid stdin stdout errorLog ->+ -- Unmask exceptions only once we've installed an exception handler to+ -- cleanup the process again+ interruptible (aux pid stdin stdout errorLog) `Ex.onException` sigKillProcess pid where- aux :: ProcessID -> FilePath -> FilePath -> FilePath -> IO (RunActions a)+ aux :: Pid -> WriteChannel -> ReadChannel -> FilePath -> IO (RunActions a) aux pid stdin stdout errorLog = do runWaitChan <- newChan :: IO (Chan SnippetAction) reqChan <- newChan :: IO (Chan GhcRunRequest)@@ -304,7 +313,7 @@ , supplyStdin = writeChan reqChan . GhcRunInput , forceCancel = do cancel respThread- ignoreIOExceptions $ signalProcess sigKILL pid+ ignoreIOExceptions $ sigKillProcess pid ignoreIOExceptions $ removeFile errorLog writeChan runWaitChan SnippetForceTerminated }
IdeSession/RPC/Client.hs view
@@ -29,9 +29,7 @@ import System.Exit (ExitCode) import System.IO (Handle, hClose) import System.IO.Temp (openTempFile)-import System.Posix.IO (createPipe, closeFd, fdToHandle)-import System.Posix.Signals (signalProcess, sigKILL)-import System.Posix.Types (Fd)+ import System.Process ( createProcess , proc@@ -40,7 +38,7 @@ , CreateProcess(cwd, env) , getProcessExitCode )-import System.Process.Internals (withProcessHandle, ProcessHandle__(..))+import IdeSession.Util.PortableProcess import qualified Control.Exception as Ex import qualified System.Directory as Dir import Distribution.Verbosity (normal)@@ -54,7 +52,10 @@ import IdeSession.Util.Logger import IdeSession.RPC.API import IdeSession.RPC.Stream+import IdeSession.RPC.Sockets +import Network+ -------------------------------------------------------------------------------- -- Client-side API -- --------------------------------------------------------------------------------@@ -109,19 +110,17 @@ -> Maybe [(String, String)] -- ^ Environment -> IO RpcServer forkRpcServer path args workingDir menv = do- (requestR, requestW) <- createPipe- (responseR, responseW) <- createPipe+ request <- makeSocket+ response <- makeSocket tmpDir <- Dir.getTemporaryDirectory (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc-server-.log" hClose errorLogHandle - let showFd :: Fd -> String- showFd fd = show (fromIntegral fd :: Int)-+ ports <- mapM socketPort [request, response] let args' = args ++ [errorLogPath]- ++ map showFd [requestR, requestW, responseR, responseW]+ ++ map portToString ports fullPath <- pathToExecutable path (Nothing, Nothing, Nothing, ph) <- createProcess (proc fullPath args') {@@ -129,17 +128,13 @@ env = menv } - -- Close the ends of the pipes that we're not using, and convert the rest- -- to handles- closeFd requestR- closeFd responseW- requestW' <- fdToHandle requestW- responseR' <- fdToHandle responseR+ request' <- acceptHandle request+ response' <- acceptHandle response st <- newMVar RpcRunning- input <- newStream responseR'+ input <- newStream response' return RpcServer {- rpcRequestW = requestW'+ rpcRequestW = request' , rpcErrorLog = errorLogPath , rpcProc = Just ph , rpcState = st@@ -159,27 +154,24 @@ -- -- It is the responsibility of the caller to make sure that each triplet -- of named pipes is only used for RPC connection.-connectToRpcServer :: FilePath -- ^ stdin named pipe- -> FilePath -- ^ stdout named pipe+connectToRpcServer :: WriteChannel -- ^ stdin+ -> ReadChannel -- ^ stdout -> FilePath -- ^ logfile for storing exceptions -> (RpcServer -> IO a) -> IO a-connectToRpcServer requestW responseR errorLog act =- Ex.bracket (openPipeForWriting requestW timeout) hClose $ \requestW' ->- Ex.bracket (openPipeForReading responseR timeout) hClose $ \responseR' -> do+connectToRpcServer (WriteChannel request) (ReadChannel response) errorLog act =+ Ex.bracket (connectToPort request) hClose $ \request' ->+ Ex.bracket (connectToPort response) hClose $ \response' -> do st <- newMVar RpcRunning- input <- newStream responseR'+ input <- newStream response' act $ RpcServer {- rpcRequestW = requestW'+ rpcRequestW = request' , rpcErrorLog = errorLog , rpcProc = Nothing , rpcState = st , rpcResponseR = input- , rpcIdentity = requestW+ , rpcIdentity = (show request) -- TODO is it possible to make a better identifier? }- where- timeout :: Int- timeout = 1000000 -- 1sec -- | Specialized form of 'rpcConversation' to do single request and wait for -- a single response.@@ -275,23 +267,9 @@ forceTerminate :: RpcServer -> IO () forceTerminate server = case rpcProc server of- Just ph ->- withProcessHandle ph $ \p_ ->- case p_ of- ClosedHandle _ ->- leaveHandleAsIs p_- OpenHandle pID -> do- signalProcess sigKILL pID- leaveHandleAsIs p_+ Just ph -> killProcessHandle ph Nothing -> Ex.throwIO $ userError "forceTerminate: parallel connection"- where- leaveHandleAsIs _p =-#if MIN_VERSION_process(1,2,0)- return ()-#else- return (_p, ())-#endif -- | Like modifyMVar, but terminate the server on exceptions withRpcServer :: RpcServer
IdeSession/Update.hs view
@@ -60,7 +60,7 @@ import System.Exit (ExitCode(..)) import System.FilePath ((</>)) import System.IO.Temp (createTempDirectory)-import System.Posix.IO.ByteString+import System.IO (IOMode(..)) import System.Process (proc, CreateProcess(..), StdStream(..), createProcess, waitForProcess, interruptProcessGroupOf, terminateProcess) import qualified Control.Exception as Ex import qualified Data.ByteString as BSS@@ -87,6 +87,8 @@ import IdeSession.Util import IdeSession.Util.BlockingOps import IdeSession.Util.Logger+import IdeSession.Util.PortableIO+import IdeSession.Util.PortableFiles (moduleNameToExeName) import qualified IdeSession.Query as Query import qualified IdeSession.Strict.List as List import qualified IdeSession.Strict.Map as Map@@ -416,8 +418,12 @@ then do (idleState', mex) <- runSessionUpdate justRestarted update ideStaticInfo updateStatus ideCallbacks idleState case mex of- Nothing -> return $ IdeSessionIdle idleState'- Just ex -> return $ IdeSessionServerDied ex idleState'+ Nothing -> do+ updateStatus Public.UpdateStatusDone+ return $ IdeSessionIdle idleState'+ Just ex -> do+ updateStatus $ Public.UpdateStatusFailed (Text.pack (show ex))+ return $ IdeSessionServerDied ex idleState' else do $logInfo $ "Restarting session due to update requiring it." unless justRestarted $ updateStatus Public.UpdateStatusRequiredRestart@@ -426,7 +432,7 @@ go justRestarted update (IdeSessionServerDied ex idleState) = do let msg = Text.pack (show ex) $logInfo $ "Restarting session due to server dieing: " <> msg- unless justRestarted $ updateStatus (Public.UpdateStatusCrashRestart msg)+ unless justRestarted $ updateStatus (Public.UpdateStatusErrorRestart msg) let restartParams = sessionRestartParams idleState update restart justRestarted update restartParams idleState go _ _ IdeSessionShutdown =@@ -445,7 +451,7 @@ ServerRestarted idleState' resetSession -> go True (resetSession <> update) (IdeSessionIdle idleState') ServerRestartFailed idleState' -> do- updateStatus (Public.UpdateStatusServerDied "Failed to restart ide-backend-server")+ updateStatus Public.UpdateStatusFailedToRestart return $ IdeSessionServerDied failedToRestart idleState' -- | @requiresSessionRestart st upd@ returns true if update @upd@ requires a@@ -549,15 +555,15 @@ overrideVar (var, Just val) env = Map.insert var val env overrideVar (var, Nothing) env = Map.delete var env envMap = foldr overrideVar (Map.fromList envInherited) envOverride- let exePath = distDir </> "build" </> m </> m+ let exePath = distDir </> "build" </> m </> moduleNameToExeName m exeExists <- Dir.doesFileExist exePath unless exeExists $ fail $ "No compiled executable file " ++ m ++ " exists at path " ++ exePath ++ "." (stdRd, stdWr) <- liftIO createPipe- std_rd_hdl <- fdToHandle stdRd- std_wr_hdl <- fdToHandle stdWr+ std_rd_hdl <- fdToHandle stdRd ReadMode+ std_wr_hdl <- fdToHandle stdWr WriteMode let cproc = (proc exePath args) { cwd = Just dataDir , env = Just $ Map.toList envMap , create_group = True
IdeSession/Update/ExecuteSessionUpdate.hs view
@@ -21,7 +21,6 @@ import System.Exit (ExitCode(..)) import System.FilePath (makeRelative, (</>), takeExtension, replaceExtension, dropFileName) import System.FilePath.Find (find, always, extension, (&&?), (||?), fileType, (==?), FileType (RegularFile))-import System.Posix.Files (setFileTimes, getFileStatus, modificationTime) import qualified Control.Exception as Ex import qualified Data.Accessor.Monad.MTL.State as Acc import qualified Data.ByteString.Char8 as BSS@@ -43,6 +42,7 @@ import IdeSession.Update.IdeSessionUpdate import IdeSession.Util import IdeSession.Util.Logger+import IdeSession.Util.PortableFiles import qualified IdeSession.GHC.Client as GHC import qualified IdeSession.Strict.IORef as IORef import qualified IdeSession.Strict.IntMap as IntMap
TestSuite/TestSuite/Session.hs view
@@ -93,11 +93,14 @@ Just rest -> dotToSlash . dropExtension . dropFirstPathComponent $ rest Nothing -> takeBaseName path + -- reverse slash for Windows, TODO proper handling of paths+ isSep c = c == '/' || c == '\\'+ dropFirstPathComponent :: FilePath -> FilePath- dropFirstPathComponent = tail . dropWhile (/= '/')+ dropFirstPathComponent = tail . dropWhile (not . isSep) dotToSlash :: String -> String- dotToSlash = map $ \c -> if c == '/' then '.' else c+ dotToSlash = map $ \c -> if isSep c then '.' else c -- | Specification: --
TestSuite/TestSuite/State.hs view
@@ -65,6 +65,7 @@ import qualified Data.ByteString.Lazy as L import IdeSession+import IdeSession.Util (UnsupportedOnNonUnix(..)) {------------------------------------------------------------------------------- Test suite top-level@@ -307,8 +308,9 @@ instance IsTest TestCase where -- TODO: Measure time and use for testPassed in normal case run _ test _ = runTestCase test `catches` [- Handler $ \(HUnitFailure msg) -> return (testFailed msg)- , Handler $ \(SkipTest msg) -> return (testPassed ("Skipped (" ++ msg ++ ")"))+ Handler $ \(HUnitFailure msg) -> return (testFailed msg)+ , Handler $ \(SkipTest msg) -> return (testPassed ("Skipped (" ++ msg ++ ")"))+ , Handler $ \(UnsupportedOnNonUnix msg) -> return (testPassed ("Skipped, unsupported on non-Unix (" ++ msg ++ ")")) ] -- TODO: Should this reflect testCaseEnabled?
TestSuite/TestSuite/Tests/Integration.hs view
@@ -10,6 +10,7 @@ import Test.HUnit hiding (test) import IdeSession+import IdeSession.Util.PortableProcess (sigKillExitCode) import TestSuite.Assertions import TestSuite.Session import TestSuite.State@@ -190,7 +191,7 @@ assertNoErrors session updateSessionD session update3 0 -- 0: nothing to generate code from exitCodeBefore <- getGhcExitCode serverBefore- assertEqual "exitCodeBefore" (Just (ExitFailure (-9))) exitCodeBefore -- SIGKILL+ assertEqual "exitCodeBefore" (Just (ExitFailure sigKillExitCode)) exitCodeBefore -- SIGKILL where update = originalUpdate <> updateCodeGeneration True update2 = mconcat $ map updateSourceFileDelete lm
TestSuite/TestSuite/Tests/Performance.hs view
@@ -18,18 +18,18 @@ testGroupPerformance :: TestSuiteEnv -> TestTree testGroupPerformance env = testGroup "Performance" [- stdTest env "Perf: Load testPerfMs modules in one call 1" test_OneCall_1- , stdTest env "Perf: Load testPerfMs modules in one call 2" test_OneCall_2- , stdTest env "Perf: Load testPerfMs modules in many calls 1" test_ManyCalls_1- , stdTest env "Perf: Load testPerfMs modules in many calls 2" test_ManyCalls_2- , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 1" test_Batch_OneCall_1- , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 2" test_Batch_OneCall_2- , stdTest env "Perf: Update a module testPerfTimes with no context 1" test_NoContext_1- , stdTest env "Perf: Update a module testPerfTimes with no context 2" test_NoContext_2- , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 1" test_UpdateModule_1- , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 2" test_UpdateModule_2- , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 1" test_UpdateAndRun_1- , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 2" test_UpdateAndRun_2+ -- stdTest env "Perf: Load testPerfMs modules in one call 1" test_OneCall_1+ -- , stdTest env "Perf: Load testPerfMs modules in one call 2" test_OneCall_2+ -- , stdTest env "Perf: Load testPerfMs modules in many calls 1" test_ManyCalls_1+ -- , stdTest env "Perf: Load testPerfMs modules in many calls 2" test_ManyCalls_2+ -- , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 1" test_Batch_OneCall_1+ -- , stdTest env "Perf: Load 4xtestPerfMs modules, each batch in one call 2" test_Batch_OneCall_2+ -- , stdTest env "Perf: Update a module testPerfTimes with no context 1" test_NoContext_1+ -- , stdTest env "Perf: Update a module testPerfTimes with no context 2" test_NoContext_2+ -- , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 1" test_UpdateModule_1+ -- , stdTest env "Perf: Update a module testPerfTimes with testPerfMs modules 2" test_UpdateModule_2+ -- , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 1" test_UpdateAndRun_1+ -- , stdTest env "Perf: Update and run a module testPerfTimes with testPerfMs modules 2" test_UpdateAndRun_2 ] test_OneCall_1 :: TestSuiteEnv -> Assertion
ide-backend.cabal view
@@ -1,5 +1,5 @@ name: ide-backend-version: 0.10.0+version: 0.10.0.1 synopsis: An IDE backend library description: See README.md for more details license: MIT@@ -64,8 +64,7 @@ containers >= 0.4.1 && < 1, bytestring >= 0.9.2 && < 1, mtl >= 2.1 && < 2.3,- async >= 2.0 && < 2.1,- unix >= 2.5 && < 2.8,+ async >= 2.0 && < 2.2, temporary >= 1.1.2.4 && < 1.3, text >= 0.11 && < 1.3, binary >= 0.7.1.0 && < 0.8,@@ -81,7 +80,8 @@ -- our own private fork: Cabal-ide-backend >= 1.23, ghc-prim,- pretty-show+ pretty-show,+ network default-language: Haskell2010 default-extensions: MonoLocalBinds@@ -99,6 +99,11 @@ GeneralizedNewtypeDeriving ghc-options: -Wall -fno-warn-unused-do-bind + if os(windows)+ build-depends: unix-compat >= 0.4.1.1 && < 0.4.2+ else+ build-depends: unix >= 2.5 && < 2.8+ executable ide-backend-exe-cabal main-is: ide-backend-exe-cabal.hs other-modules: IdeSession.ExeCabalServer@@ -113,10 +118,9 @@ random >= 1.0.1 && < 2, bytestring >= 0.9.2 && < 1, mtl >= 2.1 && < 2.3,- async >= 2.0 && < 2.1,- aeson >= 0.6.2 && < 0.10,+ async >= 2.0 && < 2.2,+ aeson >= 0.6.2 && < 0.11, executable-path >= 0.0 && < 0.1,- unix >= 2.5 && < 2.8, temporary >= 1.1.2.4 && < 1.3, bytestring-trie >= 0.2 && < 0.3, unordered-containers >= 0.2.3 && < 0.3,@@ -135,7 +139,9 @@ -- our own private fork: Cabal-ide-backend >= 1.22, ghc-prim,- pretty-show+ pretty-show,+ network,+ unix-compat >= 0.4.1.1 && < 0.4.2 default-language: Haskell2010 default-extensions: MonoLocalBinds,@@ -144,6 +150,9 @@ DeriveDataTypeable ghc-options: -Wall -fno-warn-unused-do-bind + if !os(windows)+ Build-Depends: unix >= 2.5 && < 2.8+ test-suite TestSuite type: exitcode-stdio-1.0 main-is: TestSuite.hs@@ -199,7 +208,6 @@ process, directory, stm,- unix, random, Cabal-ide-backend, containers,@@ -220,6 +228,11 @@ FlexibleInstances OverlappingInstances + if os(windows)+ Build-Depends: unix-compat >= 0.4.1.1 && < 0.4.2+ else+ Build-Depends: unix >= 2.5 && < 2.8+ test-suite rpc-server type: exitcode-stdio-1.0 main-is: rpc-server.hs@@ -232,17 +245,17 @@ containers >= 0.4.1 && < 1, random >= 1.0.1 && < 2, bytestring >= 0.9.2 && < 1,- async >= 2.0 && < 2.1,+ async >= 2.0 && < 2.2, aeson >= 0.6 && < 0.10, temporary >= 1.1.2.4 && < 1.3, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, HUnit >= 1.2 && < 1.3, executable-path >= 0.0 && < 0.1,- unix >= 2.5 && < 2.8, binary >= 0.7.1.0 && < 0.8, ide-backend, ide-backend-common,+ network, template-haskell default-language: Haskell2010@@ -251,3 +264,8 @@ other-extensions: CPP, TemplateHaskell, ScopedTypeVariables, DeriveDataTypeable ghc-options: -Wall -fno-warn-unused-do-bind++ if os(windows)+ Build-Depends: unix-compat >= 0.4.1.1 && < 0.4.2+ else+ Build-Depends: unix >= 2.5 && < 2.8
test/TestTools.hs view
@@ -3,7 +3,7 @@ import qualified Control.Exception as Ex import Data.Typeable (typeOf)-import System.Posix.Signals (Signal, raiseSignal)+import IdeSession.Util.PortableProcess import Test.HUnit (Assertion, assertBool, assertFailure) -- | Check that the given IO action raises the specified exception@@ -29,5 +29,9 @@ exceptionType (Ex.SomeException ex) = show (typeOf ex) -- | Like 'raiseSignal', but with a more general type-throwSignal :: Signal -> IO a-throwSignal signal = raiseSignal signal >> undefined+-- throwSignal :: Signal -> IO a+-- throwSignal signal = raiseSignal signal >> undefined++-- | Like 'raiseSigKill', but with a more general type+throwSigKill :: IO a+throwSigKill = raiseSigKill >> undefined
test/rpc-server.hs view
@@ -14,9 +14,8 @@ import System.Environment.Executable (getExecutablePath) import System.FilePath ((</>)) import System.IO (hClose)-import System.IO.Temp (withTempDirectory, openTempFile)-import System.Posix.Files (createNamedPipe)-import System.Posix.Signals (sigKILL)+import System.IO.Temp (openTempFile)+-- import System.Posix.Signals (sigKILL) import qualified Control.Concurrent.Async as Async import qualified Control.Exception as Ex import qualified Data.Binary as Binary@@ -26,8 +25,10 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertEqual) +import Network import IdeSession.RPC.Client import IdeSession.RPC.Server+import IdeSession.RPC.Sockets import TestTools --------------------------------------------------------------------------------@@ -328,7 +329,7 @@ modifyMVar_ firstRequest $ \isFirst -> do if isFirst then put req- else throwSignal sigKILL+ else throwSigKill return False -- | Test server which gets killed between requests@@ -343,7 +344,7 @@ testKillAsyncServer _errorLog RpcConversation{..} = forever $ do req <- get :: IO String -- Fork a thread which causes the server to crash 0.5 seconds after the request- forkIO $ threadDelay 250000 >> throwSignal sigKILL+ forkIO $ threadDelay 250000 >> throwSigKill put req -- | Test crash during decoding@@ -408,7 +409,7 @@ testKillMultiServer _errorLog RpcConversation{..} = forever $ do req <- get :: IO Int forM_ [req, req - 1 .. 1] $ put- throwSignal sigKILL+ throwSigKill -- | Like 'KillMulti', but now the server gets killed *between* messages testKillAsyncMulti :: RpcServer -> Assertion@@ -419,7 +420,7 @@ testKillAsyncMultiServer :: FilePath -> RpcConversation -> IO () testKillAsyncMultiServer _errorLog RpcConversation{..} = forever $ do req <- get- forkIO $ threadDelay (250000 + (req - 1) * 50000) >> throwSignal sigKILL+ forkIO $ threadDelay (250000 + (req - 1) * 50000) >> throwSigKill forM_ [req, req - 1 .. 1] $ \i -> threadDelay 50000 >> put i --------------------------------------------------------------------------------@@ -497,26 +498,22 @@ put str go ConcurrentServerSpawn -> do- pipes <- newEmptyMVar :: IO (MVar (String, String, String))+ pipes <- newEmptyMVar :: IO (MVar (WriteChannel, ReadChannel, String)) forkIO $ do- withTempDirectory "." "rpc" $ \tempDir -> do- let stdin = tempDir </> "stdin"- stdout = tempDir </> "stdout"- stderr = tempDir </> "stderr"-- createNamedPipe stdin 0o600- createNamedPipe stdout 0o600+ stdin <- makeSocket+ stdout <- makeSocket - tmpDir <- Dir.getTemporaryDirectory- (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc.log"- hClose errorLogHandle+ tmpDir <- Dir.getTemporaryDirectory+ (errorLogPath, errorLogHandle) <- openTempFile tmpDir "rpc.log"+ hClose errorLogHandle - -- Once we have created the pipes we can tell the client- putMVar pipes (stdin, stdout, errorLogPath)- concurrentConversation stdin stdout stderr testConversationServer+ [stdinPort, stdoutPort] <- mapM socketPort [stdin, stdout]+ -- Once we have created the sockets we can tell the client+ putMVar pipes (WriteChannel stdinPort, ReadChannel stdoutPort, errorLogPath)+ concurrentConversation stdin stdout errorLogPath testConversationServer - (stdin, stdout, errorLogPath) <- readMVar pipes- put (stdin, stdout, errorLogPath)+ (stdinPort, stdoutPort, errorLogPath) <- readMVar pipes+ put (stdinPort, stdoutPort, errorLogPath) go ConcurrentServerTerminate -> do put ()@@ -581,7 +578,7 @@ , testGroup "Client code errors" [ testRPC "illscoped" testIllscoped , testRPC "invalidReqType" testInvalidReqType--- , testRPC "invalidRespType" testInvalidRespType+ -- , testRPC "invalidRespType" testInvalidRespType ] , testGroup "Concurrent conversations" [ testRPC "concurrent" testConcurrent