diff --git a/IdeSession/Config.hs b/IdeSession/Config.hs --- a/IdeSession/Config.hs +++ b/IdeSession/Config.hs @@ -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 diff --git a/IdeSession/ExeCabalServer.hs b/IdeSession/ExeCabalServer.hs --- a/IdeSession/ExeCabalServer.hs +++ b/IdeSession/ExeCabalServer.hs @@ -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 diff --git a/IdeSession/GHC/Client.hs b/IdeSession/GHC/Client.hs --- a/IdeSession/GHC/Client.hs +++ b/IdeSession/GHC/Client.hs @@ -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 } diff --git a/IdeSession/RPC/Client.hs b/IdeSession/RPC/Client.hs --- a/IdeSession/RPC/Client.hs +++ b/IdeSession/RPC/Client.hs @@ -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 diff --git a/IdeSession/Update.hs b/IdeSession/Update.hs --- a/IdeSession/Update.hs +++ b/IdeSession/Update.hs @@ -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 diff --git a/IdeSession/Update/ExecuteSessionUpdate.hs b/IdeSession/Update/ExecuteSessionUpdate.hs --- a/IdeSession/Update/ExecuteSessionUpdate.hs +++ b/IdeSession/Update/ExecuteSessionUpdate.hs @@ -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 diff --git a/TestSuite/TestSuite/Session.hs b/TestSuite/TestSuite/Session.hs --- a/TestSuite/TestSuite/Session.hs +++ b/TestSuite/TestSuite/Session.hs @@ -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: -- diff --git a/TestSuite/TestSuite/State.hs b/TestSuite/TestSuite/State.hs --- a/TestSuite/TestSuite/State.hs +++ b/TestSuite/TestSuite/State.hs @@ -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? diff --git a/TestSuite/TestSuite/Tests/Integration.hs b/TestSuite/TestSuite/Tests/Integration.hs --- a/TestSuite/TestSuite/Tests/Integration.hs +++ b/TestSuite/TestSuite/Tests/Integration.hs @@ -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 diff --git a/TestSuite/TestSuite/Tests/Performance.hs b/TestSuite/TestSuite/Tests/Performance.hs --- a/TestSuite/TestSuite/Tests/Performance.hs +++ b/TestSuite/TestSuite/Tests/Performance.hs @@ -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 diff --git a/ide-backend.cabal b/ide-backend.cabal --- a/ide-backend.cabal +++ b/ide-backend.cabal @@ -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 diff --git a/test/TestTools.hs b/test/TestTools.hs --- a/test/TestTools.hs +++ b/test/TestTools.hs @@ -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 diff --git a/test/rpc-server.hs b/test/rpc-server.hs --- a/test/rpc-server.hs +++ b/test/rpc-server.hs @@ -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