diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +## 0.1.0 + +* Change "return value" of both getPort and setPort from PortNumber-type to Port(Int)-type +* Add Capture*WithFile to data Capture + +## 0.0.1.13 + +* Fix bug that throw error even if exit code is ExitSuccess diff --git a/src/Test/Sandbox.hs b/src/Test/Sandbox.hs --- a/src/Test/Sandbox.hs +++ b/src/Test/Sandbox.hs @@ -94,7 +94,6 @@ import qualified Data.Map as M import Data.Maybe import Data.Serialize (Serialize) -import Network hiding (sendTo) import Prelude hiding (error) import System.Exit import System.IO @@ -211,7 +210,7 @@ signal process sig = uninterruptibleMask_ $ do sp <- getProcess process case spInstance sp of - Just (RunningInstance ph _ _) -> liftIO $ hSignalProcess sig ph + Just (RunningInstance ph _ _ _) -> liftIO $ hSignalProcess sig ph _ -> throwError $ "Process " ++ process ++ " is not running." -- | Gracefully stops all registered processes (in their reverse registration order) @@ -256,7 +255,7 @@ -- | Returns an unbound user TCP port and stores it for future reference. getPort :: String -- ^ Port name for future reference - -> Sandbox PortNumber + -> Sandbox Port getPort name = do env <- get case M.lookup name $ ssAllocatedPorts env of @@ -266,7 +265,7 @@ -- | Explicitely sets a port to be returned by getPort. setPort :: String -- ^ Port name for future reference -> Int -- ^ TCP port number - -> Sandbox PortNumber + -> Sandbox Port setPort name port = do let port' = fromIntegral port bindable <- liftIO $ isBindable (fromIntegral port) diff --git a/src/Test/Sandbox/Internals.hs b/src/Test/Sandbox/Internals.hs --- a/src/Test/Sandbox/Internals.hs +++ b/src/Test/Sandbox/Internals.hs @@ -49,6 +49,7 @@ import System.Random.Shuffle import Test.Sandbox.Process +type Port = Int type SandboxStateRef = IORef SandboxState newtype Sandbox a = Sandbox { @@ -86,8 +87,8 @@ , ssDataDir :: FilePath , ssProcesses :: Map String SandboxedProcess , ssProcessOrder :: [String] - , ssAllocatedPorts :: Map String PortNumber - , ssAvailablePorts :: [PortNumber] + , ssAllocatedPorts :: Map String Port + , ssAvailablePorts :: [Port] , ssFiles :: Map String FilePath , ssVariables :: Map String ByteString } @@ -101,13 +102,18 @@ , spInstance :: Maybe SandboxedProcessInstance , spPid :: Maybe ProcessID , spPGid :: Maybe ProcessGroupID + , spHandles :: [Handle] } -data Capture = CaptureStdout - | CaptureStderr - | CaptureBoth +data Capture = + CaptureStdout + | CaptureStderr + | CaptureBoth + | CaptureStdoutWithFile FilePath + | CaptureStderrWithFile FilePath + | CaptureBothWithFile FilePath FilePath -data SandboxedProcessInstance = RunningInstance ProcessHandle Handle (Maybe Handle) +data SandboxedProcessInstance = RunningInstance ProcessHandle Handle (Maybe Handle) [Handle] | StoppedInstance ExitCode (Maybe String) get :: Sandbox SandboxState @@ -162,7 +168,7 @@ env <- get if isJust (M.lookup name (ssProcesses env)) then throwError $ "Process " ++ name ++ " is already registered in the test environment." - else do let sp = SandboxedProcess name bin args wait capture Nothing Nothing Nothing + else do let sp = SandboxedProcess name bin args wait capture Nothing Nothing Nothing [] _ <- put env { ssProcesses = M.insert name sp (ssProcesses env) , ssProcessOrder = ssProcessOrder env ++ [name] } @@ -180,7 +186,7 @@ case M.lookup name (ssProcesses env) of Just sp -> let spi = spInstance sp in case spi of - Just (RunningInstance ph _ oh) -> do + Just (RunningInstance ph _ oh _) -> do ec <- liftIO $ getProcessExitCode ph case ec of Just ec' -> do -- Process is dead; update the environment @@ -231,14 +237,14 @@ env <- get case M.lookup name (ssAllocatedPorts env) of Nothing -> throwError $ "No such allocated port: " ++ name - Just port -> do h <- liftIO . withSocketsDo $ connectTo "localhost" $ PortNumber port + Just port -> do h <- liftIO . withSocketsDo $ connectTo "localhost" $ PortNumber $ PortNum $ fromIntegral port liftIO $ do B.hPutStr h $ B.pack input hFlush h b <- hReadWithTimeout h timeout liftIO $ hClose h return $! B.unpack b -getNewPort :: String -> Sandbox PortNumber +getNewPort :: String -> Sandbox Port getNewPort name = do env <- get case ssAvailablePorts env of @@ -253,7 +259,7 @@ #if defined __LINUX__ -isBindable :: PortNumber -> IO Bool +isBindable :: Port -> IO Bool isBindable port = do ports <- getPorts return $ not $ S.member (fromIntegral port) $ S.unions $ (map S.singleton $ ports) @@ -290,12 +296,12 @@ flatten (x:xs) = x ++ flatten xs #else -isBindable :: PortNumber -> IO Bool +isBindable :: Port -> IO Bool isBindable p = withSocketsDo $ do s <- socket AF_INET Stream defaultProtocol setSocketOption s ReuseAddr 1 localhost <- inet_addr "127.0.0.1" - let sa = SockAddrInet p localhost + let sa = SockAddrInet (PortNum (fromIntegral p)) localhost r <- (bind s sa >> isBound s) `catch` ((\_ -> return False) :: SomeException -> IO Bool) close s @@ -316,26 +322,39 @@ startProcess' = do bin <- getProcessBinary sp args <- mapM (liftIO . expand) $ spArgs sp - (hOutRO, hOutRW, hErrRW) <- case spCapture sp of - Just co -> liftIO $ do (pRO, pRW) <- createPipe - hRO <- fdToHandle pRO - hRW <- fdToHandle pRW - case co of - CaptureStdout -> return (Just hRO, UseHandle hRW, Inherit) - CaptureStderr -> return (Just hRO, Inherit, UseHandle hRW) - CaptureBoth -> return (Just hRO, UseHandle hRW, UseHandle hRW) - Nothing -> return (Nothing, Inherit, Inherit) - (Just ih, _, _, ph) <- liftIO $ createProcess $ ((proc bin args) {create_group = True} ) { std_in = CreatePipe + (hOutRO, hOutRW, hErrRW, handles) <- case spCapture sp of + Just co -> liftIO $ do + (pRO, pRW) <- createPipe + hRO <- fdToHandle pRO + hRW <- fdToHandle pRW + case co of + CaptureStdout -> return (Just hRO, UseHandle hRW, Inherit, []) + CaptureStderr -> return (Just hRO, Inherit, UseHandle hRW, []) + CaptureBoth -> return (Just hRO, UseHandle hRW, UseHandle hRW, []) + CaptureStdoutWithFile filepath_o -> do + hd <- openFile filepath_o WriteMode + return (Nothing, UseHandle hd, Inherit, [hd]) + CaptureStderrWithFile filepath_e -> do + hd <- openFile filepath_e WriteMode + return (Nothing, Inherit, UseHandle hd, [hd]) + CaptureBothWithFile filepath_o filepath_e-> do + hdo <- openFile filepath_o WriteMode + hde <- openFile filepath_e WriteMode + return (Nothing, UseHandle hdo, UseHandle hde, [hdo,hde]) + Nothing -> return (Nothing, Inherit, Inherit, []) + (Just ih, _, _, ph) <- liftIO $ createProcess $ (proc bin args) {create_group = True + , std_in = CreatePipe , std_out = hOutRW , std_err = hErrRW } - when (isJust $ spWait sp) $ liftIO . threadDelay $ fromJust (spWait sp) * secondInµs + when (isJust $ spWait sp) $ do + liftIO . threadDelay $ fromJust (spWait sp) * secondInµs errno <- liftIO $ getProcessExitCode ph case errno of Nothing -> do pid <- liftIO $ hGetProcessID ph pgid <- liftIO $ getProcessGroupIDOf pid updateProcess sp { - spInstance = Just $ RunningInstance ph ih hOutRO + spInstance = Just $ RunningInstance ph ih hOutRO handles , spPid = Just pid , spPGid = Just pgid } @@ -356,15 +375,18 @@ stopProcess :: SandboxedProcess -> Sandbox SandboxedProcess stopProcess sp = case spInstance sp of - Just (RunningInstance ph _ _) -> do + Just (RunningInstance ph _ _ handles) -> do let wait = if isNothing $ spWait sp then 50000 else fromJust (spWait sp) * secondInµs `div` 5 whenM isVerbose $ liftIO $ putStrLn ("sending sigterm : " ++ spName sp) liftIO $ do terminateProcess ph threadDelay wait stillRunning <- liftM isNothing $ liftIO $ getProcessExitCode ph when stillRunning $ do - whenM isVerbose $ liftIO $ putStrLn ("sending sigkill : " ++ spName sp) - liftIO $ killProcess ph + whenM isVerbose $ + liftIO $ putStrLn ("sending sigkill : " ++ spName sp) + liftIO $ do + killProcess ph + forM_ handles hClose stopProcess =<< getProcess (spName sp) _ -> return sp @@ -415,14 +437,14 @@ getProcessInputHandle :: SandboxedProcess -> Sandbox Handle getProcessInputHandle sp = case spInstance sp of - Just (RunningInstance _ ih _) -> return ih + Just (RunningInstance _ ih _ _) -> return ih _ -> throwError $ "No such handle for " ++ spName sp ++ ". " ++ "Is the process started?" getProcessCapturedOutputHandle :: SandboxedProcess -> Sandbox Handle getProcessCapturedOutputHandle sp = case spInstance sp of - Just (RunningInstance _ _ (Just oh)) -> return oh + Just (RunningInstance _ _ (Just oh) _) -> return oh _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". " ++ "Is capture activated?" diff --git a/test-sandbox.cabal b/test-sandbox.cabal --- a/test-sandbox.cabal +++ b/test-sandbox.cabal @@ -1,5 +1,5 @@ Name: test-sandbox -Version: 0.0.1.13 +Version: 0.1.0 Cabal-Version: >= 1.14 Category: Testing Synopsis: Sandbox for system tests @@ -19,13 +19,16 @@ Build-Type: Simple Homepage: http://gree.github.io/haskell-test-sandbox/ Bug-Reports: https://github.com/gree/haskell-test-sandbox/issues + +Extra-Source-Files: ChangeLog.md + Source-Repository head Type: git Location: https://github.com/gree/haskell-test-sandbox Source-Repository this Type: git Location: https://github.com/gree/haskell-test-sandbox - Tag: test-sandbox_0.0.1.11 + Tag: test-sandbox_0.1.0 Library Exposed-modules: Test.Sandbox