diff --git a/src/Test/Sandbox.hs b/src/Test/Sandbox.hs --- a/src/Test/Sandbox.hs +++ b/src/Test/Sandbox.hs @@ -1,3 +1,4 @@ +{-#LANGUAGE ScopedTypeVariables#-} {- | Module : Test.Sandbox Maintainer: Benjamin Surma @@ -33,7 +34,12 @@ -- * Initialization , sandbox + , withSandbox + -- * Calling sandbox on IO + , runSandbox + , runSandbox' + -- * Registering processes , register @@ -80,8 +86,7 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.Trans (liftIO) -import Control.Monad.Trans.Error (runErrorT) -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Reader (ask) import Control.Monad.Error.Class (catchError, throwError) import qualified Data.ByteString.Char8 as B import Data.Default @@ -91,25 +96,38 @@ import Data.Serialize (Serialize) import Network hiding (sendTo) import Prelude hiding (error) -import qualified Prelude (error) import System.Exit import System.IO import System.IO.Temp import System.Posix hiding (release) +import System.Environment import Test.Sandbox.Internals +cleanUp :: Sandbox () +cleanUp = do + stopAll + whenM isCleanUp $ do + cleanUpProcesses + -- | Creates a sandbox and execute the given actions in the IO monad. sandbox :: String -- ^ Name of the sandbox environment -> Sandbox a -- ^ Action to perform -> IO a sandbox name actions = withSystemTempDirectory (name ++ "_") $ \dir -> do env <- newSandboxState name dir - (runReaderT . runErrorT . runSandbox) (actions `finally` stopAll) env >>= either + runSandbox (actions `finally` cleanUp) env >>= either (\error -> do hPutStrLn stderr error throwIO $ userError error) return +withSandbox :: (SandboxStateRef -> IO a) -> IO a +withSandbox actions = do + name <- getProgName + sandbox name $ do + ref <- ask + liftIO $ actions ref + -- | Optional parameters when registering a process in the Sandbox monad. data ProcessSettings = ProcessSettings { psWait :: Maybe Int -- ^ Time to wait (in s.) before checking that the process is still up @@ -155,14 +173,14 @@ displayBanner sp <- getProcess process whenM isVerbose $ liftIO $ putStr ("Starting process " ++ process ++ "... ") >> hFlush stdout - updateProcess =<< startProcess sp + _ <- updateProcess =<< startProcess sp whenM isVerbose $ liftIO $ putStrLn "Done." -- | Starts all registered processes (in their registration order) startAll :: Sandbox () startAll = uninterruptibleMask_ $ do displayBanner - whenM isVerbose $ liftIO $ putStr "Starting all sandbox processes... " >> hFlush stdout + whenM isVerbose $ liftIO $ putStrLn "Starting all sandbox processes... " >> hFlush stdout silently $ do env <- get mapM_ start (ssProcessOrder env) whenM isVerbose $ liftIO $ putStrLn "Done." @@ -182,9 +200,9 @@ -> Sandbox () stop process = uninterruptibleMask_ $ do sp <- getProcess process - whenM isVerbose $ liftIO $ putStr ("Stopping process " ++ process ++ "... ") >> hFlush stdout - updateProcess =<< stopProcess sp - whenM isVerbose $ liftIO $ putStrLn "Done." + whenM isVerbose $ liftIO $ putStrLn ("Stopping process " ++ process ++ "("++ show (spPid sp) ++ ")... ") >> hFlush stdout + _ <- updateProcess =<< stopProcess sp + whenM isVerbose $ liftIO $ putStrLn "Done." >> hFlush stdout -- | Sends a POSIX signal to a process signal :: String -- ^ Process name @@ -200,8 +218,8 @@ stopAll :: Sandbox () stopAll = uninterruptibleMask_ $ do whenM isVerbose $ liftIO $ putStr "Stopping all sandbox processes... " >> hFlush stdout - silently $ do env <- get - mapM_ stop (reverse $ ssProcessOrder env) + env <- get + mapM_ stop (reverse $ ssProcessOrder env) whenM isVerbose $ liftIO $ putStrLn "Done." -- | Returns the effective binary path of a registered process. @@ -253,7 +271,7 @@ let port' = fromIntegral port bindable <- liftIO $ isBindable (fromIntegral port) if bindable then do env <- get - put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env }) + _ <- put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env }) return port' else throwError $ "Unable to bind port " ++ show port @@ -264,7 +282,7 @@ setFile name contents = do env <- get (file, env') <- liftIO $ setFile' name contents env - put env' + _ <- put env' return file -- | Returns the path of a file previously created by setFile. @@ -284,7 +302,7 @@ -> Sandbox b withVariable key value action = bracket (do env <- get let old = M.lookup key $ ssVariables env - setVariable key value + _ <- setVariable key value return old) (\old -> case old of Nothing -> unsetVariable key 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 @@ -4,21 +4,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Sandbox.Internals where import Control.Applicative (Applicative) import Control.Concurrent -import Control.Exception.Lifted +import Control.Exception.Lifted hiding (throwTo) import Control.Monad import Control.Monad.Base (MonadBase) -import Control.Monad.Error (MonadError, catchError, throwError) +import Control.Monad.Except (MonadError, catchError, throwError) import Control.Monad.Loops import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Monad.Trans.Error (ErrorT) -import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char @@ -31,8 +33,6 @@ import GHC.IO.Handle import Network import Network.Socket -import Prelude hiding (error) -import qualified Prelude (error) import System.Directory import System.Exit import System.FilePath @@ -43,18 +43,32 @@ import System.Process.Internals (withProcessHandle, ProcessHandle__(OpenHandle)) import System.Random import System.Random.Shuffle +import Test.Sandbox.Process type SandboxStateRef = IORef SandboxState newtype Sandbox a = Sandbox { - runSandbox :: ErrorT String (ReaderT SandboxStateRef IO) a + runSB :: ExceptT String (ReaderT SandboxStateRef IO) a } deriving (Applicative, Functor, Monad, MonadBase IO, MonadError String, MonadReader (IORef SandboxState), MonadIO) instance MonadBaseControl IO Sandbox where - newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ErrorT String (ReaderT SandboxStateRef IO)) a } - liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSandbox) + newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ExceptT String (ReaderT SandboxStateRef IO)) a } + liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSB) restoreM = Sandbox . restoreM . runStMSandbox +runSandbox :: Sandbox a -> SandboxStateRef -> IO (Either String a) +runSandbox = runReaderT . runExceptT . runSB + +errorHandler :: String -> IO a +errorHandler error' = do + hPutStrLn stderr error' + throwIO $ userError error' + +runSandbox' :: SandboxStateRef -> Sandbox a -> IO a +runSandbox' env' action = do + val <- runSandbox action env' + either errorHandler return val + data SandboxState = SandboxState { ssName :: String , ssDataDir :: FilePath @@ -73,6 +87,8 @@ , spWait :: Maybe Int , spCapture :: Maybe Capture , spInstance :: Maybe SandboxedProcessInstance + , spPid :: Maybe ProcessID + , spPGid :: Maybe ProcessGroupID } data Capture = CaptureStdout @@ -93,19 +109,19 @@ pretty :: SandboxState -> String pretty env = - header env ++ - "-- Data directory: " ++ ssDataDir env ++ "\n\ - \-- Allocated ports: " ++ unwords (map show $ M.assocs $ ssAllocatedPorts env) ++ "\n\ - \-- Configuration files: " ++ unwords (M.elems $ ssFiles env) ++ "\n\ - \-- Registered processes: " ++ unwords (ssProcessOrder env) + header env + ++ "-- Data directory: " ++ ssDataDir env ++ "\n" + ++ "-- Allocated ports: " ++ unwords (map show $ M.assocs $ ssAllocatedPorts env) ++ "\n" + ++ "-- Configuration files: " ++ unwords (M.elems $ ssFiles env) ++ "\n" + ++ "-- Registered processes: " ++ unwords (ssProcessOrder env) ++ footer header :: SandboxState -> String header te = - "\n\ - \##------------------------------------------------------------------------------\n\ - \ ## " ++ title ++ replicate (72 - length title) ' ' ++ " --\n\ - \## ##---------------------------------------------------------------------------\n" + "\n" + ++ "##------------------------------------------------------------------------------\n" + ++ " ## " ++ title ++ replicate (72 - length title) ' ' ++ " --\n" + ++ "## ##---------------------------------------------------------------------------\n" where title = ssName te ++ " system test environment" footer :: String @@ -116,7 +132,11 @@ newSandboxState name dir = do gen <- newStdGen let availablePorts = shuffle' userPorts (length userPorts) gen - where userPorts = [49152..65535] + where userPorts = [5001..32767] + -- Ephemeral port is used by operating system which allocates it for tcp-client. + -- The port area is below. + -- IANN(freebsd and win7): [49152.. 65535],Linux: [32768..61000],WinXP: [1025..5000] + -- Do not use these area for "userPorts" to avoid conflict. newIORef $ SandboxState name dir M.empty [] M.empty availablePorts M.empty M.empty registerProcess :: @@ -130,9 +150,10 @@ 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 - put env { ssProcesses = M.insert name sp (ssProcesses env) - , ssProcessOrder = ssProcessOrder env ++ [name] } + 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] + } return sp isValidProcessName :: String -> Bool @@ -155,7 +176,7 @@ Just oh' -> liftM Just $ liftIO $ hGetContents oh' Nothing -> return Nothing let sp' = sp { spInstance = Just $ StoppedInstance ec' o } - updateProcess sp' + _ <- updateProcess sp' return sp' Nothing -> return sp _ -> return sp @@ -164,7 +185,7 @@ updateProcess :: SandboxedProcess -> Sandbox SandboxedProcess updateProcess sp = do env <- get - put env { ssProcesses = M.insert (spName sp) sp (ssProcesses env) } + _ <- put env { ssProcesses = M.insert (spName sp) sp (ssProcesses env) } return sp secondInµs :: Int @@ -211,16 +232,56 @@ case ssAvailablePorts env of [] -> throwError "No user ports left." ports -> do (port, ports') <- liftIO $ takeBindablePort' ports - put env { ssAllocatedPorts = M.insert name port $ ssAllocatedPorts env - , ssAvailablePorts = ports' } + _ <- put env { ssAllocatedPorts = M.insert name port $ ssAllocatedPorts env + , ssAvailablePorts = ports' } return port where takeBindablePort' pl = do pl' <- dropWhileM (liftM not . isBindable) pl return (head pl', tail pl') + +#if defined __LINUX__ isBindable :: PortNumber -> IO Bool +isBindable port = do + ports <- getPorts + return $ not $ S.member (fromIntegral port) $ S.unions $ (map S.singleton $ ports) + where + getPort :: String -> Maybe Int + getPort v = + if v =~ pattern + then + case (v =~ pattern) of + [[_str,port']] -> + case readHex port' of + [(port'',_)] -> Just port'' + _ -> Nothing + _ -> Nothing + else Nothing + where + pattern = "^ *[0-9]+: [0-9A-F]+:([0-9A-F]+) .*" + + getPorts :: IO [Int] + getPorts = do + let files = [ + "/proc/net/tcp", + "/proc/net/tcp6", + "/proc/net/udp", + "/proc/net/udp6"] + list <- forM files $ \file -> do { + v <- readFile file ; + v `seq` return $ catMaybes $ map getPort $ lines v + } `catch` (\(_ :: SomeException) -> return []) + return $ flatten list + where + flatten :: [[a]] -> [a] + flatten [] = [] + flatten (x:xs) = x ++ flatten xs + +#else +isBindable :: PortNumber -> 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 r <- (bind s sa >> isBound s) @@ -228,6 +289,10 @@ close s return $! r +#endif + + + startProcess :: SandboxedProcess -> Sandbox SandboxedProcess startProcess sp = case spInstance sp of @@ -248,16 +313,23 @@ 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) { std_in = CreatePipe + (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 errno <- liftIO $ getProcessExitCode ph case errno of - Nothing -> updateProcess sp { spInstance = Just $ RunningInstance ph ih hOutRO } - Just errno' -> throwError $ "Process " ++ spName sp ++ " not running.\n\ - \ - command-line: " ++ formatCommandLine bin args ++ "\n\ - \ - exit code: " ++ show errno' + Nothing -> do + pid <- liftIO $ hGetProcessID ph + pgid <- liftIO $ getProcessGroupIDOf pid + updateProcess sp { + spInstance = Just $ RunningInstance ph ih hOutRO + , spPid = Just pid + , spPGid = Just pgid + } + Just errno' -> throwError $ "Process " ++ spName sp ++ " not running.\n" + ++ " - command-line: " ++ formatCommandLine bin args ++ "\n" + ++ " - exit code: " ++ show errno' formatCommandLine :: String -> [String] -> String formatCommandLine bin args = unwords $ bin : args @@ -267,13 +339,33 @@ case spInstance sp of Just (RunningInstance ph _ _) -> 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 $ liftIO $ killProcess ph + when stillRunning $ do + whenM isVerbose $ liftIO $ putStrLn ("sending sigkill : " ++ spName sp) + liftIO $ killProcess ph stopProcess =<< getProcess (spName sp) _ -> return sp +#if defined(__MACOSX__) || defined(__WIN32__) +#else +getAvailablePids :: Sandbox [ProcessID] +getAvailablePids = do + stat <- get + let pgids = catMaybes (map (\(_k,v) -> spPGid v) (M.toList (ssProcesses stat))) + pids <- liftIO $ getProcessIDs pgids + return pids +#endif + +cleanUpProcesses :: Sandbox () +cleanUpProcesses = do + stat <- get + let pgids = catMaybes (map (\(_k,v) -> spPGid v) (M.toList (ssProcesses stat))) + whenM isVerbose $ liftIO $ putStrLn ("Starting to kill process groups " ++ show pgids) + liftIO $ cleanUpProcessGroupIDs pgids + hSignalProcess :: Signal -> ProcessHandle -> IO () hSignalProcess s h = do pid <- hGetProcessID h @@ -285,7 +377,11 @@ hGetProcessID :: ProcessHandle -> IO ProcessID hGetProcessID h = withProcessHandle h $ \x -> case x of +#if MIN_VERSION_process(1,2,0) + OpenHandle pid -> return pid +#else OpenHandle pid -> return (x, pid) +#endif _ -> throwIO $ userError "Unable to retrieve child process ID." interactWithProcess :: SandboxedProcess -> String -> Int -> Sandbox String @@ -301,15 +397,15 @@ getProcessInputHandle sp = case spInstance sp of Just (RunningInstance _ ih _) -> return ih - _ -> throwError $ "No such handle for " ++ spName sp ++ ". \ - \Is the process started?" + _ -> 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 - _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". \ - \Is capture activated?" + _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". " + ++ "Is capture activated?" getProcessBinary :: SandboxedProcess -> Sandbox FilePath getProcessBinary sp = do @@ -317,8 +413,8 @@ case existing of exBin:_ -> return exBin [] -> throwError $ "Unable to find the executable for the test process \"" - ++ spName sp ++ "\"\r\n\ - \Considered paths were: " ++ show bins + ++ spName sp ++ "\"\r\n" + ++ "Considered paths were: " ++ show bins where bins = getProcessCandidateBinaries sp findExecutables :: [FilePath] -> IO [FilePath] @@ -362,7 +458,7 @@ -> Sandbox a setVariable name new = do env <- get - put $ env { ssVariables = M.insert name (encode new) (ssVariables env) } + _ <- put $ env { ssVariables = M.insert name (encode new) (ssVariables env) } return new -- | Checks that a custom sandbox variable is set. @@ -397,6 +493,12 @@ verbosityKey :: String verbosityKey = "__VERBOSITY__" +isCleanUp :: Sandbox Bool +isCleanUp = getVariable cleanUpKey True + +cleanUpKey :: String +cleanUpKey = "__CLEANUP__" + displayBanner :: Sandbox () displayBanner = do displayed <- checkVariable var @@ -407,9 +509,10 @@ installSignalHandlers :: Sandbox () installSignalHandlers = do installed <- checkVariable var - unless installed $ liftIO . void $ do installHandler sigTERM handler Nothing - installHandler sigQUIT handler Nothing - installHandler sigABRT handler Nothing + unless installed $ liftIO . void $ do _ <- installHandler sigTERM handler Nothing + _ <- installHandler sigQUIT handler Nothing + _ <- installHandler sigABRT handler Nothing + return () void $ setVariable var True where var = "__HANDLERS_INSTALLED__" handler = Catch $ signalProcess sigINT =<< getProcessID diff --git a/src/Test/Sandbox/Process.hs b/src/Test/Sandbox/Process.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandbox/Process.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module Test.Sandbox.Process where +import System.Posix.Types +import System.Posix.Signals +import Text.Regex.Posix +import Data.Maybe +import Control.Exception +import Control.Monad +import System.Directory +import qualified Data.Set as S + +#if defined(__MACOSX__) || defined(__WIN32__) +#else +data ProcessInfo = ProcessInfo { + piPid :: ProcessID +, piStat :: String +, piPpid :: ProcessID +, piPgid :: ProcessGroupID +} deriving (Show,Eq,Read) + +getProcessInfo :: String -> Maybe ProcessInfo +getProcessInfo v = + if v =~ pattern + then + case v =~ pattern of + [[_str,pid,stat,ppid,pgid]] -> Just $ ProcessInfo (read pid) stat (read ppid) (read pgid) + _ -> Nothing + else + Nothing + where + pattern = "^([0-9]+) \\([^\\)]*\\) ([RSDZTW]) ([0-9]+) ([0-9]+) [0-9]+ .*" + +getProcessInfos :: IO [ProcessInfo] +getProcessInfos = do + dirs <- getDirectoryContents "/proc" + let processes = filter ( =~ "[0-9]+") dirs + stats <- forM processes $ \ps -> do { + file <- (readFile $ "/proc/" ++ ps ++ "/stat") ; + file `seq` return $ getProcessInfo file + } `catch` (\(_ :: SomeException) -> return Nothing) + return $ catMaybes stats + +getProcessGroupIDs :: IO [ProcessGroupID] +getProcessGroupIDs = do + infos <- getProcessInfos + return $ map (\info -> piPgid info) infos + +getProcessIDs :: [ProcessGroupID] -> IO [ProcessID] +getProcessIDs pgids = do + infos <- getProcessInfos + let pgids' = S.fromList $ pgids + return $ map (\info -> piPid info) $ filter (\info -> S.member (piPgid info) pgids') infos +#endif + +cleanUpProcessGroupIDs :: [ProcessGroupID] -> IO () +cleanUpProcessGroupIDs pgids = do + forM_ pgids $ \pgid -> do + signalProcessGroup sigKILL pgid `catch` (\(_::SomeException) -> return ()) + 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.8 +Version: 0.0.1.9 Cabal-Version: >= 1.14 Category: Testing Synopsis: Sandbox for system tests @@ -25,18 +25,42 @@ Source-Repository this Type: git Location: https://github.com/gree/haskell-test-sandbox - Tag: test-sandbox_0.0.1.8 + Tag: test-sandbox_0.0.1.9 Library Exposed-modules: Test.Sandbox Test.Sandbox.Internals + Test.Sandbox.Process Build-Depends: base >=4 && <5, bytestring, cereal, containers, data-default, directory, filepath, lifted-base, - monad-control, monad-loops, mtl, network, process >= 1.1 && < 1.2, - random, random-shuffle, temporary, transformers, - transformers-base, unix + monad-control, monad-loops, mtl, network, process, + random, random-shuffle, temporary, transformers >= 0.4, + transformers-base, unix, regex-posix Hs-source-dirs: src + Default-Language: Haskell2010 + ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: test.hs + hs-source-dirs: test,dist/build/autogen + ghc-options: -Wall + + build-depends: base + , test-sandbox + , hspec + , template-haskell + , heredoc + , hastache + , text + , containers + , unix + , mtl + , transformers + , regex-posix + , directory + , process + , QuickCheck Default-Language: Haskell2010 diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic (assert,monadicIO) +import Test.Sandbox +import qualified Test.Sandbox.Internals as I +import Text.Heredoc +import qualified Text.Hastache as H +import qualified Text.Hastache.Context as H +import qualified Data.Text.Lazy as TL +import qualified Data.Text as T +import qualified Data.Map as M +import System.Posix.Files +import Data.IORef +import Data.Char +import Control.Concurrent + +a2b :: String -> String +a2b [] = [] +a2b ('a':xs) = 'b':xs +a2b (x:xs) = x:a2b xs + +a2btest :: I.SandboxStateRef -> [Char] -> Property +a2btest ref str' = a2btest' ref $ filter isAlphaNum str' + +a2btest' :: I.SandboxStateRef -> [Char] -> Property +a2btest' ref str' = + monadicIO $ do + v <- liftIO $ runSandbox' ref $ interactWith "sed_regex" (str' ++ "\n") 1 + assert $ v == ((a2b str') ++ "\n") + +main :: IO () +main = withSandbox $ \gref -> do + hspec $ do + describe "Basic Test" $ do + it "interactive Test by sandbox" $ do + sandbox "hogehoge" $ do + start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout } + v <- interactWith "sed_regex" "a\n" 1 + liftIO $ v `shouldBe` "b\n" + it "interactive Test by withSandbox" $ do + withSandbox $ \ref -> do + val <- runSandbox' ref $ do + start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout } + interactWith "sed_regex" "a\n" 1 + val `shouldBe` "b\n" + it "interactive Test : QuickCheck(setup)" $ do + val <- runSandbox' gref $ do + start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout } + interactWith "sed_regex" "a\n" 1 + val `shouldBe` "b\n" + it "interactive Test : QuickCheck(run)" $ + property $ a2btest gref + it "setFile" $ do + withSandbox $ \ref -> do + let content = + [str|#!/bin/env bash + |while true ; do echo hhh ; sleep 1;done + |] + putStr content + file <- runSandbox' ref $ setFile "str1" content + readFile file `shouldReturn` content + it "set/getVariable" $ do + withSandbox $ \ref -> do + runSandbox' ref $ do + v <- I.isVerbose + liftIO $ v `shouldBe` True + _ <- setVariable I.verbosityKey False + v' <- I.isVerbose + liftIO $ v' `shouldBe` False + runSandbox' ref I.isVerbose `shouldReturn` False + _ <- runSandbox' ref $ setVariable I.verbosityKey True + runSandbox' ref I.isVerbose `shouldReturn` True +#if defined(__MACOSX__) || defined(__WIN32__) +#else + describe "signal test" $ do + it "send kill signal for process groups" $ do + val <- newIORef $ error "do not eval this" + withSandbox $ \ref -> runSandbox' ref $ do + file <- setFile "str1" + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode file + fil2 <- setFile' "str2" + [("file",file)] + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |{{file}}& + |{{file}}& + |{{file}}& + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode fil2 + _ <- register "scr1" fil2 [] def + startAll + liftIO $ writeIORef val ref + pids <- I.getAvailablePids + liftIO $ threadDelay $ 1 * 1000 * 1000 + liftIO $ (length pids >= 4) `shouldBe` True + ref' <- readIORef val + pids <- runSandbox' ref' $ I.getAvailablePids + length pids `shouldBe` 0 + + it "send kill signal for process groups" $ do + sandbox "test" $ do + file <- setFile "str1" + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode file + fil2 <- setFile' "str2" + [("file",file)] + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |{{file}}& + |{{file}}& + |{{file}}& + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode fil2 + _ <- register "scr1" fil2 [] def + startAll + pids <- I.getAvailablePids + liftIO $ (length pids >= 4) `shouldBe` True + it "not send kill signal for process groups" $ do + val <- newIORef $ error "do not eval this" + withSandbox $ \ref -> runSandbox' ref $ do + file <- setFile "str1" + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode file + fil2 <- setFile' "str2" + [("file",file)] + [str|#!/usr/bin/env bash + |trap "echo catch signal" 1 2 3 15 + |{{file}}& + |{{file}}& + |{{file}}& + |while true ; do echo hhh ; sleep 1;done + |] + liftIO $ setExecuteMode fil2 + _ <- register "scr1" fil2 [] def + startAll + _ <- setVariable I.cleanUpKey False + pids <- I.getAvailablePids + liftIO $ writeIORef val ref + liftIO $ do + (length pids >= 4) `shouldBe` True + ref' <- readIORef val + pids <- runSandbox' ref' $ I.getAvailablePids + (length pids > 0 ) `shouldBe` True + pids' <- runSandbox' ref' $ do + I.cleanUpProcesses + I.getAvailablePids + length pids' `shouldBe` 0 +#endif + +setFile' :: H.MuVar a + => String + -> [(String, a)] + -> String + -> Sandbox FilePath +setFile' filename keyValues template = do + str' <- H.hastacheStr + H.defaultConfig + (H.encodeStr template) + (H.mkStrContext context') + setFile filename $ T.unpack $ TL.toStrict str' + where + context' str' = (M.fromList (map (\(k,v) -> (k,H.MuVariable v)) keyValues)) M.! str' + +setExecuteMode :: FilePath -> IO () +setExecuteMode file = do + stat <- getFileStatus file + setFileMode file (fileMode stat `unionFileModes` ownerExecuteMode)