test-sandbox 0.0.1.13 → 0.1.0
raw patch · 4 files changed
+68/−36 lines, 4 files
Files
- ChangeLog.md +8/−0
- src/Test/Sandbox.hs +3/−4
- src/Test/Sandbox/Internals.hs +52/−30
- test-sandbox.cabal +5/−2
+ ChangeLog.md view
@@ -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
src/Test/Sandbox.hs view
@@ -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)
src/Test/Sandbox/Internals.hs view
@@ -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?"
test-sandbox.cabal view
@@ -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